--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: ccdb.pl,v $
+
+Request Clearcase metadata from CCDB
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.4 $
+
+=item Created:
+
+Fri Mar 11 19:09:52 PST 2011
+
+=item Modified:
+
+$Date: 2011/05/05 18:33:33 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage ccdb.pl: [-u|sage] [-ve|rbose] [-deb|ug]
+ [-h|ost <host>] [-p|ort <port>] [<cmd>]
+
+ Where:
+ -u|sage: Displays usage
+
+ -ve|rbose: Be verbose
+ -deb|ug: Output debug messages
+
+ -h|ost <host>: Host to contact (Default: localhost)
+ -p|ort <port>: Port to connect to (Default: 25327)
+ <requests> Request to perform
+
+=head1 DESCRIPTION
+
+This script exercises the ccdbserver.pl daemon by requesting Clearcase metadata
+from the remote host:port that the ccdbserver.pl daemon is running on.
+
+Requests are of the variety:
+
+ <method> <parms>
+
+=cut
+
+use strict;
+use warnings;
+
+use Getopt::Long;
+use FindBin;
+
+use lib "$FindBin::Bin/lib", "$FindBin::Bin/../lib";
+
+use CCDBService;
+use Display;
+use Utils;
+
+my $VERSION = '$Revision: 1.4 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+my $me = $FindBin::Script;
+ $me =~ s/\.pl$//;
+
+local $0 = $me;
+
+my $CCDBService;
+
+sub DisplayOutput ($$) {
+ my ($status, $output) = @_;
+
+ if ($status) {
+ error "Unable to service request (Status: $status)";
+ display join "\n", @$output;
+ } else {
+ if (ref $output eq 'HASH') {
+ foreach (keys %$output) {
+ display "$_:$$output{$_}";
+ } # foreach
+ } elsif (ref $output eq 'ARRAY') {
+ foreach (@$output) {
+ my %rec = %$_;
+
+ display '-' x 80;
+
+ foreach (keys %rec) {
+ my $data = "$_:";
+ $data .= $rec{$_} ? $rec{$_} : '';
+
+ display $data;
+ } # foreach
+ } # foreach
+
+ display '=' x 80;
+ display_nolf scalar @$output;
+ display_nolf ' record';
+ display_nolf 's' if @$output > 1;
+ display ' qualified';
+ } # if
+ } # if
+
+ return;
+} # DisplayOutput
+
+sub CmdLoop () {
+ while () {
+ display_nolf "CCDB:";
+
+ my $request = <STDIN>;
+
+ chomp $request;
+
+ last if $request =~ /^exit|^quit/i;
+
+ my ($status, $output) = $CCDBService->execute ($request);
+
+ DisplayOutput ($status, $output);
+
+ last if $request =~ /stopserver/i;
+ } # while
+
+ return;
+} # CmdLoop
+
+# Main
+GetOptions (
+ 'usage' => sub { Usage },
+ 'verbose' => sub { set_verbose },
+ 'debug' => sub { set_debug },
+ 'host=s' => \$CCDBService::OPTS{CCDB_HOST},
+ 'port=s' => \$CCDBService::OPTS{CCDB_PORT},
+) or Usage "Invalid parameter";
+
+my $request = join ' ', @ARGV;
+
+display "$FindBin::Script V$VERSION";
+
+$CCDBService = CCDBService->new;
+
+my ($status, $output);
+
+$status = $CCDBService->connectToServer (
+ $CCDBService::OPTS{CCDB_HOST},
+ $CCDBService::OPTS{CCDB_PORT}
+);
+
+error 'Unable to connect to '
+ . "$CCDBService::OPTS{CCDB_HOST}:$CCDBService::OPTS{CCDB_PORT}", 1
+ unless $status;
+
+if ($request ne '') {
+ ($status, $output) = $CCDBService->execute ($request);
+
+ DisplayOutput $status, $output;
+} else {
+ CmdLoop;
+} # if
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<FindBin>
+
+L<Getopt::Long|Getopt::Long>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ Clearexec
+ Display
+ Utils
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/Clearexec.pm">Clearexec</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Utils.pm">Utils</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this script
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2010, Tellabs, Inc. All rights reserved.
+
+=cut
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: ccdbservice.pl,v $
+
+ClearCase DataBase Service: Respond to requests for Clearcase metadata from
+CCDB.
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.1 $
+
+=item Created:
+
+Fri Mar 11 17:45:57 PST 2011
+
+=item Modified:
+
+$Date: 2011/03/22 19:18:04 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage ccdbservice.pl: [-u|sage] [-ve|rbose] [-de|bug]
+ [-da|emon] [-m|ultithreaded] [-p|idfile]
+ [-l|ogfile <logfile>]
+
+ Where:
+ -u|sage: Displays usage
+
+ -ve|rbose: Be verbose
+ -de|bug: Output debug messages
+
+ -da|emon: Run in daemon mode. Use -nod|aemon to run in foreground
+ (Default: -daemon)
+ -m|ultithreaded: Multithread requests. Use -nom|ultithreaded to single
+ thread request handline (Default: -multithreaded)
+ -p|idfile: File to be created with the pid written to it (Default:
+ ccddservice.pid). Note: pidfile is only written if -daemon
+ is specified.
+ -l|ogfile: Specify alternative logfile name. Note that .log will be
+ appended. (Default: ccdbservice.log).
+
+Note: Certain options can be set in ../etc/ccdbserver.conf. See ccdbserver.conf
+for more info.
+
+=head1 DESCRIPTION
+
+This script normally runs as a daemon and accepts requests from other hosts to
+retrieve Clearcase metadata from CCDB.
+
+=cut
+
+use strict;
+use warnings;
+
+use Getopt::Long;
+use FindBin;
+
+use lib "$FindBin::Bin/lib", "$FindBin::Bin/../lib";
+
+use CCDB;
+use CCDBService;
+use Display;
+use Utils;
+
+my $VERSION = '$Revision: 1.1 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+# Extract relative path and basename from script name.
+my $me = $FindBin::Script;
+
+# Remove .pl for Perl scripts that have that extension
+$me =~ s/\.pl$//;
+
+my $pidfile =
+ "$CCDBService::OPTS{CCDB_RUNDIR}/$me.pid";
+my $logfile =
+ "$CCDBService::OPTS{CCDB_LOGDIR}/$me.log";
+
+# Main
+my $multithreaded = $CCDBService::OPTS{CCDB_MULTITHREADED};
+my $daemon = 1;
+
+GetOptions (
+ 'usage' => sub { Usage },
+ 'verbose' => sub { set_verbose },
+ 'debug' => sub { set_debug },
+ 'daemon!' => \$daemon,
+ 'multithreaded!' => \$multithreaded,
+ 'pidfile=s' => \$pidfile,
+ 'logfile=s' => \$logfile,
+) or Usage "Invalid parameter";
+
+Usage 'Extraneous options: ' . join ' ', @ARGV
+ if @ARGV;
+
+my $CCDBService = CCDBService->new;
+
+$CCDBService->setMultithreaded ($multithreaded);
+
+EnterDaemonMode $logfile, $logfile, $pidfile
+ if $daemon;
+
+display "$FindBin::Script V$VERSION started at " . localtime;
+
+$CCDBService->startServer;
+
+verbose "Server running";
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<FindBin>
+
+L<Getopt::Long|Getopt::Long>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ Clearexec
+ Display
+ Utils
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/Clearexec.pm">Clearexec</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Utils.pm">Utils</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this script
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2010, Tellabs, Inc. All rights reserved.
+
+=cut
+
--- /dev/null
+###############################################################################
+#
+# File: $RCSfile: ccdb.conf,v $
+# Revision: $Revision: 1.1 $
+# Description: Config file for CCDB
+# Author: Andrew@ClearSCM.com
+# Created: Wed Mar 9 17:31:45 PST 2011
+# Modified: $Date: 2011/03/22 19:18:04 $
+# Language: conf
+#
+# (c) Copyright 2011, Tellabs, Inc., all rights reserved
+#
+###############################################################################
+CCDB_USERNAME: ccdb
+CCDB_PASSWORD: clearcase
+CCDB_SERVER: localhost
+CCDB_MY_CNF: ccdb.my.cnf
--- /dev/null
+[mysql]
+no-auto-rehash
+
+[client]
+socket=/data/tools/ccdb/mysqltemp/mysql.sock
+port=3305
\ No newline at end of file
--- /dev/null
+-- -----------------------------------------------------------------------------
+--
+-- File: $RCSfile: ccdb.sql,v $
+-- Revision: $Revision: 1.3 $
+-- Description: Clearcase DB
+-- Author: Andrew@ClearSCM.com
+-- Created: Wed Mar 14 15:53:12 PDT 2011
+-- Modified: $Date: 2011/04/15 22:19:21 $
+-- Language: SQL
+--
+-- Copyright (c) 2011, Tellabs, Inc., all rights reserved
+--
+-- -----------------------------------------------------------------------------
+-- Warning: The following line will delete the old database!
+drop database if exists ccdb;
+
+-- Create a new database
+create database ccdb;
+
+-- Now let's focus on this new database
+use ccdb;
+
+-- registry: Defines a registry region
+create table registry (
+ name varchar (767) collate latin1_general_cs not null,
+
+ primary key (name)
+) type=innodb; -- registry
+
+-- region: Defines a region within a registry
+create table region (
+ name varchar (767) collate latin1_general_cs not null,
+ registry varchar (767) collate latin1_general_cs not null,
+
+ primary key (registry, name),
+ key regionIndex (name),
+ foreign key registryLink (registry) references registry (name)
+ on delete cascade
+ on update cascade
+) type=innodb; -- region
+
+-- vob: Defines a vob
+create table vob (
+ oid char (41),
+ name varchar (767) collate latin1_general_cs not null,
+ epoch bigint default 0,
+ type enum (
+ 'base',
+ 'ucm'
+ ) not null default 'base',
+
+ primary key (oid),
+ key nameIndex (name)
+) type=innodb; -- vob
+
+-- folder: Defines a UCM folder
+create table folder (
+ oid char (41),
+ name varchar (767) collate latin1_general_cs not null,
+ pvob varchar (767) collate latin1_general_cs not null,
+
+ primary key (oid),
+ key nameIndex (name),
+ foreign key pvobLink (pvob) references vob (name)
+ on delete cascade
+ on update cascade
+) type=innodb; -- folder
+
+-- subfolder: Defines a UCM subfolder
+create table subfolder (
+ parent varchar (767) collate latin1_general_cs not null,
+ subfolder varchar (767) collate latin1_general_cs not null,
+ pvob varchar (767) collate latin1_general_cs not null,
+
+ primary key (parent, subfolder, pvob),
+ foreign key parentLink (parent) references folder (name)
+ on delete cascade
+ on update cascade,
+ foreign key subfolderLink (subfolder) references folder (name)
+ on delete cascade
+ on update cascade,
+ foreign key pvobLink (pvob) references vob (name)
+ on delete cascade
+ on update cascade
+) type=innodb; -- subfolder
+
+-- project: Defines a UCM project
+create table project (
+ oid char (41),
+ name varchar (767) collate latin1_general_cs not null,
+ folder varchar (767) collate latin1_general_cs not null,
+ pvob varchar (767) collate latin1_general_cs not null,
+
+ primary key (oid),
+ key projectIndex (name),
+ key folderIndex (folder),
+ foreign key folderLink (folder) references folder (name)
+ on delete cascade
+ on update cascade,
+ foreign key pvobLink (pvob) references vob (name)
+ on delete cascade
+ on update cascade
+) type=innodb; -- project
+
+-- stream: Defines a UCM stream
+create table stream (
+ oid char (41),
+ name varchar (767) collate latin1_general_cs not null,
+ pvob varchar (767) collate latin1_general_cs not null,
+ project varchar (767) collate latin1_general_cs not null,
+ type enum (
+ 'integration',
+ 'regular'
+ ) not null default 'regular',
+
+ primary key (oid),
+ key streamIndex (name),
+ foreign key pvobLink (pvob) references vob (name)
+ on delete cascade
+ on update cascade,
+ foreign key projectLink (project) references project (name)
+ on delete cascade
+ on update cascade
+) type=innodb; -- stream
+
+-- activity: Defines an activity
+create table activity (
+ oid char (41),
+ name varchar (767) collate latin1_general_cs not null,
+ pvob varchar (767) collate latin1_general_cs not null,
+ type enum (
+ 'integration',
+ 'regular'
+ ) not null default 'regular',
+ submitted datetime,
+
+ primary key (oid),
+ key activityIndex (name),
+ foreign key pvobLink (pvob) references vob (name)
+ on delete cascade
+ on update cascade
+) type=innodb; -- activity
+
+-- baseline: Defines a baseline
+create table baseline (
+ oid char (41),
+ name varchar (767) collate latin1_general_cs not null,
+ pvob varchar (767) collate latin1_general_cs not null,
+
+ primary key (oid),
+ key baselineIndex (name),
+ foreign key pvobLink (pvob) references vob (name)
+ on delete cascade
+ on update cascade
+) type=innodb; -- baseline
+
+-- Cross references
+create table stream_activity_xref (
+ stream varchar (767) collate latin1_general_cs not null,
+ activity varchar (767) collate latin1_general_cs not null,
+ pvob varchar (767) collate latin1_general_cs not null,
+
+ primary key (stream, activity, pvob),
+ key streamIndex (stream),
+ key activityIndex (activity),
+ key pvobIndex (pvob),
+ foreign key streamLink (stream) references stream (name)
+ on delete cascade
+ on update cascade,
+ foreign key activityLink (activity) references activity (name)
+ on delete cascade
+ on update cascade,
+ foreign key pvobLink (pvob) references vob (name)
+ on delete cascade
+ on update cascade
+) type=innodb; -- stream_activity_xref
+
+create table stream_baseline_xref (
+ stream varchar (767) collate latin1_general_cs not null,
+ baseline varchar (767) collate latin1_general_cs not null,
+ pvob varchar (767) collate latin1_general_cs not null,
+
+ primary key (stream, baseline, pvob),
+ key streamIndex (stream),
+ key baselineIndex (baseline),
+ key pvobIndex (pvob),
+ foreign key streamLink (stream) references stream (name)
+ on delete cascade
+ on update cascade,
+ foreign key baselineLink (baseline) references baseline (name)
+ on delete cascade
+ on update cascade,
+ foreign key pvobLink (pvob) references vob (name)
+ on delete cascade
+ on update cascade
+) type=innodb; -- stream_baseline_xref
+
+
+create table changeset (
+ activity varchar (767) collate latin1_general_cs not null,
+ element varchar (767) collate latin1_general_cs not null,
+ version varchar (767) collate latin1_general_cs not null,
+ pvob varchar (767) collate latin1_general_cs not null,
+ created datetime,
+
+ primary key (activity, element, version, pvob),
+ key activityIndex (activity),
+ key elementIndex (element),
+ key elementVersionIndex (version),
+ foreign key activityLink (activity) references activity (name)
+ on delete cascade
+ on update cascade,
+ foreign key pvobLink (pvob) references vob (name)
+ on delete cascade
+ on update cascade
+) type=innodb; -- changeset
+
+create table baseline_activity_xref (
+ baseline varchar (767) collate latin1_general_cs not null,
+ activity varchar (767) collate latin1_general_cs not null,
+ pvob varchar (767) collate latin1_general_cs not null,
+
+ primary key (baseline, activity, pvob),
+ key baselineIndex (baseline),
+ key activityIndex (activity),
+ foreign key baselineLink (baseline) references baseline (name)
+ on delete cascade
+ on update cascade,
+ foreign key activityLink (activity) references activity (name)
+ on delete cascade
+ on update cascade,
+ foreign key pvobLink (pvob) references vob (name)
+ on delete cascade
+ on update cascade
+) type=innodb; -- baseline_activity_xref
--- /dev/null
+#!/bin/sh
+### BEGIN INIT INFO
+# Provides: ccdbservice
+# Required-Start: $network
+# Required-Stop: none
+# Default-Start: 2 3 4 5
+# Default-Stop: 0 1 6
+# Short-Description: Starts the ccdbservice daemon
+# Description: CCDBService is part of the CCDB package. It is a daemon
+# that runs in the background and responds to triggers which
+# indicate updates to Clearcase UCM data. Such data is stored
+# in CCDB in order to provide quicker access to UCM metadata.
+### END INIT INFO
+
+# Author: Andrew DeFaria <Andrew@ClearSCM.com>
+#
+# Do NOT "set -e"
+
+# PATH should only include /usr/* if it runs after the mountnfs.sh script
+PATH=/sbin:/usr/sbin:/bin:/usr/bin
+DESC="CCDB Service"
+NAME=ccdbservice.pl
+
+# Need to determine where this gets place. For now this is the path into my
+# development view
+CCDBBASE=/view/adefaria_tools/vob/adpscmtools/CCDB
+DAEMON=$CCDBBASE/$NAME
+PIDFILE=$CCDBBASE/$NAME.pid
+DAEMON_ARGS=""
+SCRIPTNAME=/etc/init.d/$NAME
+RUNASUSER="ccdb"
+
+# Exit if the package is not installed
+[ -x "$DAEMON" ] || exit 0
+
+# Read configuration variable file if it is present
+[ -r /etc/default/$NAME ] && . /etc/default/$NAME
+
+# Load the VERBOSE setting and other rcs variables
+. /lib/init/vars.sh
+
+# Define LSB log_* functions.
+# Depend on lsb-base (>= 3.0-6) to ensure that this file is present.
+. /lib/lsb/init-functions
+
+#
+# Function that starts the daemon/service
+#
+do_start()
+{
+ # Return
+ # 0 if daemon has been started
+ # 1 if daemon was already running
+ # 2 if daemon could not be started
+ start-stop-daemon --start --quiet --pidfile $PIDFILE --exec $DAEMON --test > /dev/null \
+ || return 1
+ start-stop-daemon --start --quiet --pidfile $PIDFILE --exec $DAEMON \
+ --chuid $RUNASUSER \
+ -- $DAEMON_ARGS \
+ || return 2
+}
+
+#
+# Function that stops the daemon/service
+#
+do_stop()
+{
+ # Return
+ # 0 if daemon has been stopped
+ # 1 if daemon was already stopped
+ # 2 if daemon could not be stopped
+ # other if a failure occurred
+ start-stop-daemon --stop --quiet --retry=TERM/30/KILL/5 --pidfile $PIDFILE --name $NAME
+ RETVAL="$?"
+ [ "$RETVAL" = 2 ] && return 2
+ # Wait for children to finish too if this is a daemon that forks
+ # and if the daemon is only ever run from this initscript.
+ # If the above conditions are not satisfied then add some other code
+ # that waits for the process to drop all resources that could be
+ # needed by services started subsequently. A last resort is to
+ # sleep for some time.
+ start-stop-daemon --stop --quiet --oknodo --retry=0/30/KILL/5 --exec $DAEMON
+ [ "$?" = 2 ] && return 2
+ # Many daemons don't delete their pidfiles when they exit.
+ rm -f $PIDFILE
+ return "$RETVAL"
+}
+
+#
+# Function that sends a SIGHUP to the daemon/service
+#
+do_reload() {
+ #
+ # If the daemon can reload its configuration without
+ # restarting (for example, when it is sent a SIGHUP),
+ # then implement that here.
+ #
+ start-stop-daemon --stop --signal 1 --quiet --pidfile $PIDFILE --name $NAME
+ return 0
+}
+
+case "$1" in
+ start)
+ [ "$VERBOSE" != no ] && log_daemon_msg "Starting $DESC" "$NAME"
+ do_start
+ case "$?" in
+ 0|1) [ "$VERBOSE" != no ] && log_end_msg 0 ;;
+ 2) [ "$VERBOSE" != no ] && log_end_msg 1 ;;
+ esac
+ ;;
+ stop)
+ [ "$VERBOSE" != no ] && log_daemon_msg "Stopping $DESC" "$NAME"
+ do_stop
+ case "$?" in
+ 0|1) [ "$VERBOSE" != no ] && log_end_msg 0 ;;
+ 2) [ "$VERBOSE" != no ] && log_end_msg 1 ;;
+ esac
+ ;;
+ status)
+ status_of_proc "$DAEMON" "$NAME" && exit 0 || exit $?
+ ;;
+ #reload|force-reload)
+ #
+ # If do_reload() is not implemented then leave this commented out
+ # and leave 'force-reload' as an alias for 'restart'.
+ #
+ #log_daemon_msg "Reloading $DESC" "$NAME"
+ #do_reload
+ #log_end_msg $?
+ #;;
+ restart|force-reload)
+ #
+ # If the "reload" option is implemented then remove the
+ # 'force-reload' alias
+ #
+ log_daemon_msg "Restarting $DESC" "$NAME"
+ do_stop
+ case "$?" in
+ 0|1)
+ do_start
+ case "$?" in
+ 0) log_end_msg 0 ;;
+ 1) log_end_msg 1 ;; # Old process is still running
+ *) log_end_msg 1 ;; # Failed to start
+ esac
+ ;;
+ *)
+ # Failed to stop
+ log_end_msg 1
+ ;;
+ esac
+ ;;
+ *)
+ #echo "Usage: $SCRIPTNAME {start|stop|restart|reload|force-reload}" >&2
+ echo "Usage: $SCRIPTNAME {start|stop|status|restart|force-reload}" >&2
+ exit 3
+ ;;
+esac
+
+:
--- /dev/null
+###############################################################################
+#
+# File: $RCSfile: ccdbservice.conf,v $
+# Revision: $Revision: 1.1 $
+# Description: Config file for Clearexec
+# Author: Andrew@ClearSCM.com
+# Created: Fri Mar 11 17:58:31 PST 2011
+# Modified: $Date: 2011/03/22 19:18:04 $
+# Language: conf
+#
+# (c) Copyright 2011, Tellabs, Inc., all rights reserved
+#
+###############################################################################
+CCDB_HOST: lnxsc021
+CCDB_PORT: 8355
+CCDB_MULTITHREADED: 1
+CCDB_LOGDIR: .
+CCDB_RUNDIR: .
\ No newline at end of file
--- /dev/null
+=pod
+
+=head1 NAME $RCSfile: CCDB.pm,v $
+
+Object oriented interface to CCDB.
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.4 $
+
+=item Created
+
+Wed Mar 9 17:03:48 PST 2011
+
+=item Modified
+
+$Date: 2011/04/15 22:27:45 $
+
+=back
+
+=head1 SYNOPSIS
+
+Provides the CCDB object which handles all interaction with the CCDB
+database. Similar add/change/delete/update methods for other record types. In
+general you must orient your record hashs to have the appropriately named
+keys that correspond to the database. Also see method documentation for
+specifics about the method you are envoking.
+
+ # Create new CCDB object
+ my $ccdb= new CCDB;
+
+ # Add a new system
+ my %project= (
+ name => 'The Next Thing',
+ pvob => '8800_projects',
+ description => 'This is the greatest thing since sliced bread',
+ );
+
+ my ($err, $msg) = $CCDB->AddProject (%project);
+
+ # Find projects matching '8800'
+ my @projects = $ccdb->FindProject ('8800');
+
+ # Get a project by name
+ my %project = $ccdb->GetProject ('8800_projects');
+
+ # Update project
+ my %update = (
+ 'description' => 'Greatest thing since the net!',
+ );
+
+ my ($err, $msg) = $ccdb->UpdateProject ('8800_projects', %update);
+
+ # Delete project (Warning: will delete all related records regarding this
+ # project).
+ my ($err, $msg) = $ccdb->DeleteProject ('8800_projects');
+
+=head1 DESCRIPTION
+
+This package provides and object oriented interface to the CCDB database.
+Methods are provided to manipulate records by adding, updating and deleting
+them. In general you need to specify a hash which contains keys and values
+corresponding to the database field names and values.
+
+=head1 ROUTINES
+
+The following methods are available:
+
+=cut
+
+package CCDB;
+
+use strict;
+use warnings;
+
+use Carp;
+use DBI;
+
+use FindBin;
+
+use lib "$FindBin::Bin/../../lib";
+
+use Clearcase;
+use DateUtils;
+use Display;
+use GetConfig;
+
+our %CCDBOPTS = GetConfig ("$FindBin::Bin/../etc/ccdb.conf");
+
+$CCDBOPTS{CCDB_MY_CNF} = "$FindBin::Bin/etc/$CCDBOPTS{CCDB_MY_CNF}";
+
+# Globals
+our $VERSION = '$Revision: 1.4 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+$CCDBOPTS{CCDB_USERNAME} = $ENV{CCDB_USERNAME}
+ ? $ENV{CCDB_USERNAME}
+ : $CCDBOPTS{CCDB_USERNAME}
+ ? $CCDBOPTS{CCDB_USERNAME}
+ : '<specify username>';
+$CCDBOPTS{CCDB_PASSWORD} = $ENV{CCDB_PASSWORD}
+ ? $ENV{CCDB_PASSWORD}
+ : $CCDBOPTS{CCDB_PASSWORD}
+ ? $CCDBOPTS{CCDB_PASSWORD}
+ : '<specify password>';
+$CCDBOPTS{CCDB_SERVER} = $ENV{CCDB_SERVER}
+ ? $ENV{CCDB_SERVER}
+ : $CCDBOPTS{CCDB_SERVER}
+ ? $CCDBOPTS{CCDB_SERVER}
+ : '<specify server>';
+
+# Internal methods
+sub _dberror ($$) {
+ my ($self, $msg, $statement) = @_;
+
+ my $dberr = $self->{db}->err;
+ my $dberrmsg = $self->{db}->errstr;
+
+ $dberr ||= 0;
+ $dberrmsg ||= 'Success';
+
+ my $message = '';
+
+ if ($dberr) {
+ my $function = (caller (1)) [3];
+
+ $message = "$function: $msg\nError #$dberr: $dberrmsg\n"
+ . "SQL Statement: $statement";
+ } # if
+
+ return $dberr, $message;
+} # _dberror
+
+sub _formatValues (@) {
+ my ($self, @values) = @_;
+
+ my @returnValues;
+
+ # Quote data values
+ foreach (@values) {
+ if ($_) {
+ unless ($_ eq '') {
+ push @returnValues, $self->{db}->quote ($_);
+ next;
+ } # unless
+ } # if
+
+ push @returnValues, 'null';
+ } # foreach
+
+ return @returnValues;
+} # _formatValues
+
+sub _formatNameValues (%) {
+ my ($self, %rec) = @_;
+
+ my @nameValueStrs;
+
+ push @nameValueStrs, "$_=" . $self->{db}->quote ($rec{$_})
+ foreach (keys %rec);
+
+ return @nameValueStrs;
+} # _formatNameValues
+
+sub _addRecord ($%) {
+ my ($self, $table, %rec) = @_;
+
+ my $statement = "insert into $table (";
+ $statement .= join ',', keys %rec;
+ $statement .= ') values (';
+ $statement .= join ',', $self->_formatValues (values %rec);
+ $statement .= ')';
+
+ $self->{db}->do ($statement);
+
+ return $self->_dberror ("Unable to add record to $table", $statement);
+} # _addRecord
+
+sub _deleteRecord ($;$) {
+ my ($self, $table, $condition) = @_;
+
+ my $count;
+
+ my $statement = "select count(*) from $table ";
+ $statement .= "where $condition"
+ if $condition;
+
+ my $sth = $self->{db}->prepare ($statement)
+ or return $self->_dberror ('Unable to prepare statement', $statement);
+
+ $sth->execute
+ or return $self->_dberror ('Unable to execute statement', $statement);
+
+ my @row = $sth->fetchrow_array;
+
+ $sth->finish;
+
+ if ($row[0]) {
+ $count = $row[0];
+ } else {
+ $count = 0;
+ } # if
+
+ return ($count, 'Records deleted')
+ if $count == 0;
+
+ $statement = "delete from $table ";
+ $statement .= "where $condition"
+ if $condition;
+
+ $self->{db}->do ($statement);
+
+ if ($self->{db}->err) {
+ return $self->_dberror ("Unable to delete record from $table", $statement);
+ } else {
+ return $count, 'Records deleted';
+ } # if
+} # _deleteRecord
+
+sub _updateRecord ($$%) {
+ my ($self, $table, $condition, %rec) = @_;
+
+ my $statement = "update $table set ";
+ $statement .= join ',', $self->_formatNameValues (%rec);
+ $statement .= " where $condition"
+ if $condition;
+
+ $self->{db}->do ($statement);
+
+ return $self->_dberror ("Unable to update record in $table", $statement);
+} # _updateRecord
+
+sub _checkRequiredFields ($$) {
+ my ($fields, $rec) = @_;
+
+ foreach my $fieldname (@$fields) {
+ my $found = 0;
+
+ foreach (keys %$rec) {
+ if ($fieldname eq $_) {
+ $found = 1;
+ last;
+ } # if
+ } # foreach
+
+ return "$fieldname is required"
+ unless $found;
+ } # foreach
+
+ return;
+} # _checkRequiredFields
+
+sub _getRecords ($$) {
+ my ($self, $table, $condition) = @_;
+
+ my ($err, $msg);
+
+ my $statement = "select * from $table where $condition";
+
+ my $sth = $self->{db}->prepare ($statement);
+
+ unless ($sth) {
+ ($err, $msg) = $self->_dberror ('Unable to prepare statement', $statement);
+
+ croak $msg;
+ } # if
+
+ my $status = $sth->execute;
+
+ unless ($status) {
+ ($err, $msg) = $self->_dberror ('Unable to execute statement', $statement);
+
+ croak $msg;
+ } # if
+
+ my @records;
+
+ while (my $row = $sth->fetchrow_hashref) {
+ push @records, $row;
+ } # while
+
+ return @records;
+} # _getRecord
+
+sub _getLastID () {
+ my ($self) = @_;
+
+ my $statement = 'select last_insert_id()';
+
+ my $sth = $self->{db}->prepare ($statement);
+
+ my ($err, $msg);
+
+ unless ($sth) {
+ ($err, $msg) = $self->_dberror ('Unable to prepare statement', $statement);
+
+ croak $msg;
+ } # if
+
+ my $status = $sth->execute;
+
+ unless ($status) {
+ ($err, $msg) = $self->_dberror ('Unable to execute statement', $statement);
+
+ croak $msg;
+ } # if
+
+ my @records;
+
+ my @row = $sth->fetchrow_array;
+
+ return $row[0];
+} # _getLastID
+
+sub new (;$) {
+ my ($class, $dbserver) = @_;
+
+ $dbserver ||= $CCDBOPTS{CCDB_SERVER};
+
+ my $self = bless {}, $class;
+
+ my $dbname = 'ccdb';
+ my $dbdriver = 'mysql';
+
+ $self->{db} = DBI->connect (
+ "DBI:$dbdriver:$dbname:$dbserver;"
+ . "mysql_read_default_file=$CCDBOPTS{CCDB_MY_CNF}",
+ $CCDBOPTS{CCDB_USERNAME},
+ $CCDBOPTS{CCDB_PASSWORD},
+ {PrintError => 0},
+ ) or croak (
+ "Couldn't connect to $dbname database "
+ . "as $CCDBOPTS{CCDB_USERNAME}\@$dbserver\nDBERR: $DBI::errstr"
+ );
+
+ return $self;
+} # new
+
+sub AddRecord ($$$) {
+ my ($self, $record, $required, $data) = @_;
+
+ my $Record = ucfirst $record;
+ my @requiredFields = @$required;
+
+ unless (ref $data eq 'HASH') {
+ my $VAR1;
+
+ eval $data;
+
+ $data = $VAR1;
+ } # unless
+
+ my %data = %$data;
+
+ # Determine oid if necessary
+ unless ($data{oid}) {
+ if ($record eq 'activity'
+ or $record eq 'baseline'
+ or $record eq 'folder',
+ or $record eq 'project'
+ or $record eq 'stream'
+ or $record eq 'replica'
+ or $record eq 'vob') {
+
+ if ($record eq 'vob') {
+ $data{oid} = $Clearcase::CC->name2oid (
+ 'vob:' . Clearcase::vobtag ($data{name})
+ );
+ } elsif ($record eq 'replica') {
+ $data{oid} = $Clearcase::CC->name2oid (
+ "replica:$data{replica}", $data{vob}
+ );
+ } else {
+ $data{oid} = $Clearcase::CC->name2oid (
+ "$record:$data{name}", $data{pvob}
+ );
+ } # if
+ } # if
+ } # unless
+
+ my $result = _checkRequiredFields \@requiredFields, \%data;
+
+ return -1, "Add$Record: $result"
+ if $result;
+
+ return $self->_addRecord ($record, %data);
+} # AddRecord
+
+sub DeleteRecord ($$$) {
+ my ($self, $table, $keyname, $keyvalue) = @_;
+
+ # If $keyname is an array then we have multiple keys in the database. When
+ # this is the case we assume that both $keyname and $keyvalue are references
+ # to equal sized name/value pairs and we construct the condition in the form
+ # of "<keyname1>=<keyvalue1> and <keyname2>=<keyvalue2>..."
+ my $condition;
+
+ if (ref $keyname eq 'ARRAY') {
+ for (my $i = 0; $i < @$keyname; $i++) {
+ unless ($condition) {
+ $condition = "$$keyname[$i]='$$keyvalue[$i]'"
+ } else {
+ $condition .= " and $$keyname[$i]='$$keyvalue[$i]'"
+ } # if
+ } # for
+ } else {
+ $condition = "$keyname='$keyvalue'";
+ } # if
+
+ return $self->_deleteRecord ($table, $condition);
+} # DeleteRecord
+
+sub UpdateRecord ($$$$) {
+ my ($self, $table, $keyname, $keyvalue, $update) = @_;
+
+ # If $keyname is an array then we have multiple keys in the database. When
+ # this is the case we assume that both $keyname and $keyvalue are references
+ # to equal sized name/value pairs and we construct the condition in the form
+ # of "<keyname1>=<keyvalue1> and <keyname2>=<keyvalue2>..."
+ my $condition;
+
+ if (ref $keyname eq 'ARRAY') {
+ for (my $i = 0; $i < @$keyname; $i++) {
+ unless ($condition) {
+ $condition = "$$keyname[$i] like '$$keyvalue[$i]'"
+ } else {
+ $condition .= " and $$keyname[$i] like '$$keyvalue[$i]'"
+ } # if
+ } # for
+ } else {
+ $condition = "$keyname like '$keyvalue'";
+ } # if
+
+ unless (ref $update eq 'HASH') {
+ my $VAR1;
+
+ eval $update;
+
+ $update = $VAR1;
+ } # unless
+
+ my %update = %$update;
+
+ return $self->_updateRecord ($table, $condition, %update);
+} # UpdateRecord
+
+sub GetRecord ($$$) {
+ my ($self, $table, $keyname, $keyvalue) = @_;
+
+ # If $keyname is an array then we have multiple keys in the database. When
+ # this is the case we assume that both $keyname and $keyvalue are references
+ # to equal sized name/value pairs and we construct the condition in the form
+ # of "<keyname1>=<keyvalue1> and <keyname2>=<keyvalue2>..."
+ my $condition;
+
+ if (ref $keyname eq 'ARRAY') {
+ for (my $i = 0; $i < @$keyname; $i++) {
+ $$keyvalue[$i] ||= '';
+
+ unless ($condition) {
+ $condition = "$$keyname[$i]='$$keyvalue[$i]'"
+ } else {
+ $condition .= " and $$keyname[$i]='$$keyvalue[$i]'"
+ } # if
+ } # for
+ } else {
+ $condition = "$keyname='$keyvalue'";
+ } # if
+
+ my @records = $self->_getRecords ($table, $condition);
+
+ if ($records[0]) {
+ return %{$records[0]};
+ } else {
+ return;
+ } # if
+} # GetRecord
+
+sub FindRecord ($$$;$) {
+ my ($self, $table, $keyname, $keyvalue, $additional) = @_;
+
+ # If $keyname is an array then we have multiple keys in the database. When
+ # this is the case we assume that both $keyname and $keyvalue are references
+ # to equal sized name/value pairs and we construct the condition in the form
+ # of "<keyname1> like <keyvalue1> and <keyname2> like <keyvalue2>..."
+ my $condition;
+
+ if (ref $keyname eq 'ARRAY') {
+ for (my $i = 0; $i < @$keyname; $i++) {
+ $$keyvalue[$i] ||= '';
+ $$keyvalue[$i] = '' if $$keyvalue[$i] eq '*';
+
+ unless ($condition) {
+ $condition = "$$keyname[$i] like '%$$keyvalue[$i]%'"
+ } else {
+ $condition .= " and $$keyname[$i] like '%$$keyvalue[$i]%'"
+ } # if
+ } # for
+ } else {
+ $keyvalue ||= '';
+ $keyvalue = '' if $keyvalue eq '*';
+ $condition = "$keyname like '%$keyvalue%'";
+ } # if
+
+ return $self->_getRecords ($table, $condition);
+} # FindRecord
+
+sub AddProject ($) {
+ my ($self, $data) = @_;
+
+ return $self->AddRecord (
+ 'project',
+ ['name', 'folder', 'pvob'],
+ $data
+ );
+} # AddProject
+
+sub DeleteProject ($$$) {
+ my ($self, $name, $folder, $pvob) = @_;
+
+ return $self->DeleteRecord (
+ 'project',
+ ['name', 'folder', 'pvob'],
+ [$name, $folder, $pvob]
+ );
+} # DeleteProject
+
+sub UpdateProject ($$$$) {
+ my ($self, $name, $folder, $pvob, $update) = @_;
+
+ return $self->UpdateRecord (
+ 'project',
+ ['name', 'folder', 'pvob'],
+ [$name, $folder, $pvob],
+ $update
+ );
+} # UpdateRegistry
+
+sub GetProject ($) {
+ my ($self, $name, $folder, $pvob) = @_;
+
+ return $self->GetRecord (
+ 'project',
+ ['name', 'folder', 'pvob'],
+ [$name, $folder, $pvob]
+ );
+} # GetProject
+
+sub FindProject (;$$$) {
+ my ($self, $name, $folder, $project, $pvob) = @_;
+
+ return $self->FindRecord (
+ 'project',
+ ['name', 'folder', 'pvob'],
+ [$name, $folder, $pvob]
+ );
+} # FindProject
+
+sub AddRegistry ($) {
+ my ($self, $data) = @_;
+
+ return $self->AddRecord (
+ 'registry',
+ ['name'],
+ $data
+ );
+} # AddRegistry
+
+sub DeleteRegistry ($) {
+ my ($self, $name) = @_;
+
+ return $self->DeleteRecord ('registry', 'name', $name);
+} # DeleteRegistry
+
+sub UpdateRegistry ($$) {
+ my ($self, $name, $update) = @_;
+
+ return $self->UpdateRecord ('registry', 'name', $name, $update);
+} # UpdateRegistry
+
+sub GetRegistry ($) {
+ my ($self, $name) = @_;
+
+ return $self->GetRecord ('registry', 'name', $name);
+} # GetRegistry
+
+sub FindRegistry (;$) {
+ my ($self, $name) = @_;
+
+ return $self->FindRecord ('registry', 'name', $name);
+} # FindRegistry
+
+sub AddStream ($) {
+ my ($self, $data) = @_;
+
+ # TODO: We should probably make sure that things like $$data{pvob} and
+ # $$data{name} exist in $data first. Maybe add the record (which checks for
+ # required fields) then perform an update to update the type to intergration
+ # IFF this is an intergration stream.
+
+ # Determine the integration stream for this stream's project. First get
+ # project for the stream.
+ my $pvobTag = Clearcase::vobtag ($$data{pvob});
+ my $cmd = "lsstream -fmt \"%[project]p\" $$data{name}\@$pvobTag";
+
+ my ($status, @output) = $Clearcase::CC->execute ($cmd);
+
+ if ($status == 0) {
+ my $project = $output[0];
+
+ # Now get the intergration stream for this project
+ $cmd = "lsproject -fmt \"%[istream]p\" $project\@$pvobTag";
+
+ ($status, @output) = $Clearcase::CC->execute ($cmd);
+
+ if ($status == 0) {
+ $$data{type} = 'integration'
+ if $$data{name} eq $output[0];
+ } # if
+ } # if
+
+ return $self->AddRecord (
+ 'stream',
+ ['name', 'pvob'],
+ $data
+ );
+} # AddStream
+
+sub DeleteStream ($$) {
+ my ($self, $name, $pvob) = @_;
+
+ return $self->DeleteRecord (
+ 'stream',
+ ['name', 'pvob'],
+ [$name, $pvob],
+ );
+} # DeleteStream
+
+sub DeleteStreamOID ($) {
+ my ($self, $oid) = @_;
+
+ return $self->DeleteRecord (
+ 'stream',
+ 'oid',
+ $oid
+ );
+} # DeleteStreamOID
+
+sub UpdateStream ($$$) {
+ my ($self, $name, $pvob, $update) = @_;
+
+ return $self->UpdateRecord (
+ 'stream',
+ ['name', 'pvob'],
+ [$name, $pvob],
+ $update
+ );
+} # UpdateStream
+
+sub GetStream ($$) {
+ my ($self, $name, $pvob) = @_;
+
+ return $self->GetRecord (
+ 'stream',
+ ['name', 'pvob'],
+ [$name, $pvob],
+ );
+} # GetRegistry
+
+sub FindStream (;$$) {
+ my ($self, $name, $pvob) = @_;
+
+ return $self->FindRecord (
+ 'stream',
+ ['name', 'pvob'],
+ [$name, $pvob]
+ );
+} # FindRegistry
+
+sub AddSubfolder ($) {
+ my ($self, $data) = @_;
+
+ return $self->AddRecord (
+ 'subfolder',
+ ['parent', 'subfolder', 'pvob'],
+ $data
+ );
+} # AddSubfolder
+
+sub DeleteSubfolder ($$$) {
+ my ($self, $parent, $subfolder, $pvob) = @_;
+
+ return $self->DeleteRecord (
+ 'subfolder',
+ ['parent', 'subfolder', 'pvob'],
+ [$parent, $subfolder, $pvob],
+ );
+} # DeleteSubfolder
+
+sub UpdateSubfolder ($$$$) {
+ my ($self, $parent, $subfolder, $pvob, $update) = @_;
+
+ return $self->UpdateRecord (
+ 'subfolder',
+ ['parent', 'subfolder', 'pvob'],
+ [$parent, $subfolder, $pvob],
+ $update
+ );
+} # UpdateSubfolder
+
+sub GetSubfolder ($$$) {
+ my ($self, $parent, $subfolder, $pvob) = @_;
+
+ return $self->GetRecord (
+ 'subfolder',
+ ['parent', 'subfolder', 'pvob'],
+ [$parent, $subfolder, $pvob],
+ );
+} # GetSubfolder
+
+sub FindSubfolder (;$$$) {
+ my ($self, $parent, $subfolder, $pvob) = @_;
+
+ return $self->FindRecord (
+ 'subfolder',
+ ['parent', 'subfolder', 'pvob'],
+ [$parent, $subfolder, $pvob]
+ );
+} # FindFolder
+
+sub AddActivity ($) {
+ my ($self, $data) = @_;
+
+ if ($$data{name}) {
+ $$data{type} = 'integration'
+ if $$data{name} =~ /^(deliver|rebase|integrate|revert|tlmerge)/i;
+ } # if
+
+ return $self->AddRecord (
+ 'activity',
+ ['name', 'pvob'],
+ $data
+ );
+} # AddActivity
+
+sub DeleteActivity ($$) {
+ my ($self, $name, $pvob) = @_;
+
+ return $self->DeleteRecord (
+ 'activity',
+ ['name', 'pvob'],
+ [$name, $pvob],
+ );
+} # DeleteActivity
+
+sub DeleteActivityOID ($) {
+ my ($self, $oid) = @_;
+
+ return $self->DeleteRecord (
+ 'activity',
+ 'name',
+ $oid
+ );
+} # DeleteActivityOID
+
+sub UpdateActivity ($$$) {
+ my ($self, $name, $pvob, $update) = @_;
+
+ return $self->UpdateRecord (
+ 'activity',
+ ['name', 'pvob'],
+ [$name, $pvob],
+ $update
+ );
+} # UpdateActivity
+
+sub GetActivity ($$) {
+ my ($self, $name, $pvob) = @_;
+
+ return $self->GetRecord (
+ 'activity',
+ ['name', 'pvob'],
+ [$name, $pvob],
+ );
+} # GetActivity
+
+sub FindActivity (;$$) {
+ my ($self, $name, $pvob) = @_;
+
+ return $self->FindRecord (
+ 'activity',
+ ['name', 'pvob'],
+ [$name, $pvob]
+ );
+} # FindActivity
+
+sub AddBaseline ($) {
+ my ($self, $data) = @_;
+
+ return $self->AddRecord (
+ 'baseline',
+ ['name', 'pvob'],
+ $data
+ );
+} # AddBaseline
+
+sub DeleteBaseline ($$) {
+ my ($self, $name, $pvob) = @_;
+
+ return $self->DeleteRecord (
+ 'baseline',
+ ['name', 'pvob'],
+ [$name, $pvob],
+ );
+} # DeleteBaseline
+
+sub DeleteBaselineOID ($) {
+ my ($self, $oid) = @_;
+
+ return $self->DeleteRecord (
+ 'baseline',
+ 'oid',
+ $oid,
+ );
+} # DeleteBaselineOID
+
+sub UpdateBaseline ($$$) {
+ my ($self, $name, $pvob, $update) = @_;
+
+ return $self->UpdateRecord (
+ 'baseline',
+ ['name', 'pvob'],
+ [$name, $pvob],
+ $update
+ );
+} # UpdateBaseline
+
+sub GetBaseline ($$) {
+ my ($self, $name, $pvob) = @_;
+
+ return $self->GetRecord (
+ 'baseline',
+ ['name', 'pvob'],
+ [$name, $pvob],
+ );
+} # GetBaseline
+
+sub FindBaseline (;$$) {
+ my ($self, $name, $pvob) = @_;
+
+ return $self->FindRecord (
+ 'baseline',
+ ['name', 'pvob'],
+ [$name, $pvob]
+ );
+} # FindBaseline
+
+sub DeleteElementAll ($) {
+ my ($self, $name) = @_;
+
+ my ($total, $err, $msg);
+
+ foreach ($self->FindChangeset (undef, $name)) {
+ my %changeset = %$_;
+
+ ($err, $msg) = $self->DeleteChangeset (
+ $changeset{activity},
+ $changeset{name},
+ $changeset{version},
+ $changeset{pvob},
+ );
+
+ return ($err, $msg)
+ if $msg ne 'Records deleted';
+
+ $total += $err;
+ } # foreach
+
+ return ($total, $msg);
+} # DeleteElementAll
+
+sub AddChangeset ($) {
+ my ($self, $data) = @_;
+
+ return $self->AddRecord (
+ 'changeset',
+ ['activity', 'element', 'version', 'pvob'],
+ $data
+ );
+} # AddChangeset
+
+sub DeleteChangeset ($$$$) {
+ my ($self, $activity, $element, $version, $pvob) = @_;
+
+ return $self->DeleteRecord (
+ 'changeset',
+ ['activity', 'element', 'version', 'pvob'],
+ [$activity, $element, $version, $pvob],
+ );
+} # DeleteChangeset
+
+sub UpdateChangeset ($$$$$) {
+ my ($self, $activity, $element, $version, $pvob, $update) = @_;
+
+ return $self->UpdateRecord (
+ 'changeset',
+ ['activity', 'element', 'version', 'pvob'],
+ [$activity, $element, $version, $pvob],
+ $update
+ );
+} # UpdateChangeset
+
+sub GetChangeset ($$$$) {
+ my ($self, $activity, $element, $version, $pvob) = @_;
+
+ return $self->GetRecord (
+ 'changeset',
+ ['activity', 'element', 'version', 'pvob'],
+ [$activity, $element, $version, $pvob],
+ );
+} # GetChangeset
+
+sub FindChangeset (;$$$$) {
+ my ($self, $activity, $element, $version, $pvob) = @_;
+
+ return $self->FindRecord (
+ 'changeset',
+ ['activity', 'element', 'version', 'pvob'],
+ [$activity, $element, $version, $pvob]
+ );
+} # FindChangeset
+
+sub AddFolder ($) {
+ my ($self, $data) = @_;
+
+ return $self->AddRecord (
+ 'folder',
+ ['name', 'pvob'],
+ $data
+ );
+} # AddFolder
+
+sub DeleteFolder ($$) {
+ my ($self, $folder, $pvob) = @_;
+
+ return $self->DeleteRecord (
+ 'folder',
+ ['name', 'pvob'],
+ [$folder, $pvob],
+ );
+} # DeleteFolder
+
+sub UpdateFolder ($$$) {
+ my ($self, $name, $pvob, $update) = @_;
+
+ return $self->UpdateRecord (
+ 'folder',
+ ['name', 'pvob'],
+ [$name, $pvob],
+ $update
+ );
+} # UpdateFolder
+
+sub GetFolder ($$) {
+ my ($self, $name, $pvob) = @_;
+
+ return $self->GetRecord (
+ 'folder',
+ ['name', 'pvob'],
+ [$name, $pvob],
+ );
+} # GetFolder
+
+sub FindFolder (;$$) {
+ my ($self, $name, $pvob) = @_;
+
+ return $self->FindRecord (
+ 'folder',
+ ['name', 'pvob'],
+ [$name, $pvob]
+ );
+} # FindFolder
+
+sub AddVob ($) {
+ my ($self, $data) = @_;
+
+ return $self->AddRecord (
+ 'vob',
+ ['name'],
+ $data
+ );
+} # AddVob
+
+sub DeleteVob ($) {
+ my ($self, $name) = @_;
+
+ return $self->DeleteRecord (
+ 'vob',
+ ['name'],
+ $name,
+ );
+} # DeleteVob
+
+sub UpdateVob ($$) {
+ my ($self, $name, $update) = @_;
+
+ return $self->UpdateRecord ('vob', 'name', $name, $update);
+} # UpdateVob
+
+sub GetVob ($) {
+ my ($self, $name) = @_;
+
+ return $self->GetRecord (
+ 'vob',
+ 'name',
+ $name,
+ );
+} # GetVob
+
+sub FindVob (;$$) {
+ my ($self, $name, $type) = @_;
+
+ $type ||= '';
+
+ return $self->FindRecord (
+ 'vob',
+ ['name', 'type'],
+ [$name, $type],
+ );
+} # FindVob
+
+sub AddStreamActivityXref ($) {
+ my ($self, $data) = @_;
+
+ return $self->AddRecord (
+ 'stream_activity_xref',
+ ['stream', 'activity', 'pvob'],
+ $data
+ );
+} # AddStreamActivityXref
+
+sub DeleteStreamActivityXref ($$$) {
+ my ($self, $stream, $activity, $pvob) = @_;
+
+ return $self->DeleteRecord (
+ 'stream_activity_xref',
+ ['stream', 'activity', 'pvob'],
+ [$stream, $activity, $pvob],
+ );
+} # DeleteStreamActivityXref
+
+sub UpdateStreamActivityXref ($$$$) {
+ my ($self, $stream, $activity, $pvob, $update) = @_;
+
+ return $self->UpdateRecord (
+ 'stream_activity_xref',
+ ['stream', 'activity', 'pvob'],
+ [$stream, $activity, $pvob],
+ $update
+ );
+} # UpdateStreamActivityXref
+
+sub GetStreamActivityXref ($$$) {
+ my ($self, $stream, $activity, $pvob) = @_;
+
+ return $self->GetRecord (
+ 'stream_activity_xref',
+ ['stream', 'activity', 'pvob'],
+ [$stream, $activity, $pvob],
+ );
+} # GetStreamActivityXref
+
+sub FindStreamActivityXref (;$$$) {
+ my ($self, $stream, $activity, $pvob) = @_;
+
+ return $self->FindRecord (
+ 'stream_activity_xref',
+ ['stream', 'activity', 'pvob'],
+ [$stream, $activity, $pvob]
+ );
+} # FindStreamActivityXref
+
+sub AddStreamBaselineXref ($) {
+ my ($self, $data) = @_;
+
+ return $self->AddRecord (
+ 'stream_baseline_xref',
+ ['stream', 'baseline', 'pvob'],
+ $data
+ );
+} # AddStreamBaselineXref
+
+sub DeleteStreamBaselineXref ($$$) {
+ my ($self, $stream, $baseline, $pvob) = @_;
+
+ return $self->DeleteRecord (
+ 'stream_baseline_xref',
+ ['stream', 'baseline', 'pvob'],
+ [$stream, $baseline, $pvob],
+ );
+} # DeleteStreamBaselineXref
+
+sub UpdateStreamBaselineXref ($$$$) {
+ my ($self, $stream, $baseline, $pvob, $update) = @_;
+
+ return $self->UpdateRecord (
+ 'stream_baseline_xref',
+ ['stream', 'baseline', 'pvob'],
+ [$stream, $baseline, $pvob],
+ $update
+ );
+} # UpdateStreamBaselineXref
+
+sub GetStreamBaselineXref ($$$) {
+ my ($self, $stream, $baseline, $pvob) = @_;
+
+ return $self->GetRecord (
+ 'stream_baseline_xref',
+ ['stream', 'baseline', 'pvob'],
+ [$stream, $baseline, $pvob],
+ );
+} # GetStreamBaselineXref
+
+sub FindStreamBaselineXref (;$$$) {
+ my ($self, $stream, $baseline, $pvob) = @_;
+
+ return $self->FindRecord (
+ 'stream_baseline_xref',
+ ['stream', 'baseline', 'pvob'],
+ [$stream, $baseline, $pvob]
+ );
+} # FindStreamBaselineXref
+
+sub AddBaselineActivityXref ($) {
+ my ($self, $data) = @_;
+
+ return $self->AddRecord (
+ 'baseline_activity_xref',
+ ['baseline', 'activity', 'pvob'],
+ $data
+ );
+} # AddBaselineActivityXref
+
+sub DeleteBaselineActivityXref ($$$) {
+ my ($self, $baseline, $activity, $pvob) = @_;
+
+ return $self->DeleteRecord (
+ 'baseline_activity_xref',
+ ['baseline', 'activity', 'pvob'],
+ [$baseline, $activity, $pvob],
+ );
+} # DeleteBaselineActivityXref
+
+sub UpdateBaselineActivityXref ($$$$) {
+ my ($self, $baseline, $activity, $pvob, $update) = @_;
+
+ return $self->UpdateRecord (
+ 'baseline_activity_xref',
+ ['baseline', 'activity', 'pvob'],
+ [$baseline, $activity, $pvob],
+ $update
+ );
+} # UpdateBaselineActivityXref
+
+sub GetBaselineActivityXref ($$$$) {
+ my ($self, $baseline, $activity, $pvob) = @_;
+
+ return $self->GetRecord (
+ 'baseline_activity_xref',
+ ['baseline', 'activity', 'pvob'],
+ [$baseline, $activity, $pvob],
+ );
+} # GetBaselineActivityXref
+
+sub FindBaselineActivityXref (;$$$$) {
+ my ($self, $baseline, $activity, $pvob) = @_;
+
+ return $self->FindRecord (
+ 'baseline_activity_xref',
+ ['baseline', 'activity', 'pvob'],
+ [$baseline, $activity, $pvob]
+ );
+} # FindBaselineActivityXref
+
+sub FindActivities ($$$) {
+ my ($self, $pvob, $stream, $element) = @_;
+
+ my $statement = <<"END";
+select
+ aex.activity
+from
+ changeset as cs,
+ stream_activity_xref as sax
+where
+ cs.pvob = sax.pvob and
+ cs.activity = sax.activity and
+ cs.pvob = '$pvob' and
+ sax.stream = '$stream' and
+ cs.element like '$element%'
+group by
+ cs.activity
+END
+
+ my $sth = $self->{db}->prepare ($statement);
+
+ my ($err, $msg);
+
+ unless ($sth) {
+ ($err, $msg) = $self->_dberror ('Unable to prepare statement', $statement);
+
+ croak $msg;
+ } # if
+
+ my $status = $sth->execute;
+
+ unless ($status) {
+ ($err, $msg) = $self->_dberror ('Unable to execute statement', $statement);
+
+ croak $msg;
+ } # if
+
+ my @records;
+
+ while (my $row = $sth->fetchrow_hashref) {
+ push @records, $row;
+ } # while
+
+ return @records;
+} # FindActivities
+
+1;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<Carp>
+
+L<DBI>
+
+L<FindBin>
+
+L<DBI>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ DateUtils
+ Display
+ GetConfig
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/DateUtils.pm">DateUtils</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/GetConfig.pm">GetConfig</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this module
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2011, ClearSCM, Inc. All rights reserved.
+
+=cut
--- /dev/null
+=pod
+
+=head1 NAME $RCSfile: CCDBService.pm,v $
+
+CCDBService - ClearCase DataBase Service
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.6 $
+
+=item Created
+
+Fri Mar 11 15:37:34 PST 2011
+
+=item Modified
+
+$Date: 2011/05/05 18:41:44 $
+
+=back
+
+=head1 SYNOPSIS
+
+Provides an interface to the CCDB object over the netwok. This is useful as
+neither ccperl nor cqperl have DBI installed so if clients want to talk to an
+SQL database such as MySQL they generally can't.
+
+This library implements both the daemon portion of the server and the client
+API.
+
+=head1 DESCRIPTION
+
+This client/server process (ccdbc and ccdbd) serves only an informational
+purpose. By that I mean the client can request information as described below
+but it cannot request to add/delete or update information. In other words the
+client has read only access.
+
+The caller makes requests in the form of:
+
+ <method> <parms>
+
+Different methods will return different values. See CCDB.pm.
+
+=head1 ROUTINES
+
+The following methods are available:
+
+=cut
+
+package CCDBService;
+
+use strict;
+use warnings;
+
+use Carp;
+use FindBin;
+use IO::Socket;
+use Net::hostent;
+use POSIX ":sys_wait_h";
+
+use lib "$FindBin::Bin/../../lib";
+
+use DateUtils;
+use Display;
+use GetConfig;
+
+# Seed options from config file
+our %OPTS = GetConfig ("$FindBin::Bin/../etc/ccdbservice.conf");
+
+our $VERSION = '$Revision: 1.6 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+# Override options if in the environment
+$OPTS{CCDB_HOST} = $ENV{CCDB_HOST}
+ if $ENV{CCDB_HOST};
+$OPTS{CCDB_PORT} = $ENV{CCDB_PORT}
+ if $ENV{CCDB_PORT};
+$OPTS{CCDB_MULTITHREADED} = $ENV{CCDB_MULTITHREADED}
+ if $ENV{CCDB_MULTITHREADED};
+
+sub new () {
+ my ($class) = @_;
+
+ my $ccdbservice = bless {}, $class;
+
+ $ccdbservice->{multithreaded} = $OPTS{CCDB_MULTITHREADED};
+
+ return $ccdbservice;
+} # new
+
+sub _tag ($) {
+ my ($self, $msg) = @_;
+
+ my $tag = YMDHMS;
+ $tag .= ' ';
+ $tag .= $self->{pid} ? "[$self->{pid}] " : '';
+
+ return "$tag$msg";
+} # _tag
+
+sub _verbose ($) {
+ my ($self, $msg) = @_;
+
+ verbose $self->_tag ($msg);
+
+ return;
+} # _verbose
+
+sub _debug ($) {
+ my ($self, $msg) = @_;
+
+ debug $self->_tag ($msg);
+
+ return;
+} # _debug
+
+sub _log ($) {
+ my ($self, $msg) = @_;
+
+ display $self->_tag ($msg);
+
+ return;
+} # log
+
+sub _funeral () {
+ debug 'Entered _funeral';
+
+ while (my $childpid = waitpid (-1, WNOHANG) > 0) {
+ my $status = $?;
+
+ debug "childpid: $childpid - status: $status";
+
+ if ($childpid != -1) {
+ local $SIG{CHLD} = \&_funeral;
+
+ my $msg = 'Child has died';
+ $msg .= $status ? " with status $status" : '';
+
+ verbose "[$childpid] $msg"
+ if $status;
+ } else {
+ debug "All children reaped";
+ } # if
+ } # while
+
+ return;
+} # _funeral
+
+sub _endServer () {
+ display "CCDBService V$VERSION shutdown at " . localtime;
+
+ # Kill process group
+ kill 'TERM', -$$;
+
+ # Wait for all children to die
+ while (wait != -1) {
+ # do nothing
+ } # while
+
+ # Now that we are alone, we can simply exit
+ exit;
+} # _endServer
+
+sub _restartServer () {
+ # Not sure what to do on a restart server
+ display 'Entered _restartServer';
+
+ return;
+} # _restartServer
+
+sub setMultithreaded ($) {
+ my ($self, $value) = @_;
+
+ my $oldValue = $self->{multithreaded};
+
+ $self->{multithreaded} = $value;
+
+ return $oldValue;
+} # setMultithreaded
+
+sub getMultithreaded () {
+ my ($self) = @_;
+
+ return $self->{multithreaded};
+} # getMultithreaded
+
+sub connectToServer (;$$) {
+ my ($self, $host, $port) = @_;
+
+ $host ||= $OPTS{CCDB_HOST};
+ $port ||= $OPTS{CCDB_PORT};
+
+ $self->{socket} = IO::Socket::INET->new (
+ Proto => 'tcp',
+ PeerAddr => $host,
+ PeerPort => $port,
+ );
+
+ return unless $self->{socket};
+
+ $self->{socket}->autoflush
+ if $self->{socket};
+
+ $self->{host} = $host;
+ $self->{port} = $port;
+
+ if ($self->{socket}) {
+ return 1;
+ } else {
+ return;
+ } # if
+
+ return;
+} # connectToServer
+
+sub disconnectFromServer () {
+ my ($self) = @_;
+
+ undef $self->{socket};
+
+ return;
+} # disconnectFromServer
+
+sub _serviceClient ($$) {
+ my ($self, $host, $client) = @_;
+
+ $self->_verbose ("Serving requests from $host");
+
+ # Set autoflush for client
+ $client->autoflush
+ if $client;
+
+ my $ccdb = CCDB->new;
+
+ while () {
+ # Read command from client
+ my $cmd = <$client>;
+
+ last unless $cmd;
+
+ chomp $cmd;
+
+ next if $cmd eq '';
+
+ last if $cmd =~ /^quit|^exit/i;
+
+ $self->_debug ("$host wants us to do $cmd");
+
+ my $status = 0;
+ my ($method, $rec, @keys, @values);
+
+ if ($cmd =~ /stopserver/i) {
+ if ($self->{server}) {
+ $self->_verbose ("$host requested to stop server [$self->{server}]");
+
+ # Send server hangup signal
+ kill 'HUP', $self->{server};
+ } else {
+ $self->_verbose ('Shutting down server');
+
+ print $client "CCDBService Status: 0\n";
+
+ exit;
+ } # if
+
+ $self->_debug ("Returning 0, undef");
+ } else {
+ # Parse command
+ @values = split /[^\S]+/, $cmd;
+
+ if (@values < 2) {
+ print $client "ERROR: I don't understand the command: $cmd\n";
+ print $client "Request must be of the form: <method> <parms>\n";
+ print $client "CCDB Status: 1\n";
+ next;
+ } # if
+
+ $method = shift @values;
+
+ my $values = join ' ', @values;
+
+ unless (
+ $method =~ /^get/i
+ or $method =~ /^find/i
+ or $method =~ /^add/i
+ or $method =~ /^delete/i
+ or $method =~ /^update/i) {
+ print $client "I only understand get, find, add, delete and ";
+ print $client "update operations ";
+ print $client "- not '$method'\n";
+ print $client "CCDB Status: 1\n";
+ next;
+ } # unless
+
+ $self->_debug ("Executing CCDB::$method");
+
+ my (%rec, @recs);
+
+ if ($method =~ /^get/i) {
+ eval {
+ %rec = $ccdb->$method (@values);
+ }; # eval
+
+ if ($@) {
+ print $client "$@\n";
+ print $client "CCDB Status: 1\n";
+ next;
+ } else {
+ $rec = \%rec;
+ } # if
+ } elsif ($method =~ /^find/i) {
+ eval {
+ @recs = $ccdb->$method (@values);
+ }; # eval
+
+ if ($@) {
+ print $client "$@\n";
+ print $client "CCDB Status: 1\n";
+ next;
+ } else {
+ $rec = \@recs;
+ } # if
+ } elsif ($method =~ /^add/i) {
+ my ($err, $msg);
+
+ eval {
+ ($err, $msg) = $ccdb->$method ($values);
+ }; # eval
+
+ if ($@) {
+ print $client "$@\n";
+ print $client "CCDB Status: 1\n";
+ next;
+ } else {
+ $msg = "Success"
+ if $msg eq '';
+ $rec = "Err:$err;Msg:$msg";
+ } # if
+ } elsif ($method =~ /^update/i) {
+ # Updates are tricky because there is an unknown number of parms then
+ # a hash. We will look for $VAR1 in the @values array and if we find
+ # that then that is the start of the hash.
+ my @parms;
+
+ # Since we're gonna shift off of @values we don't want to use $#values
+ # in the for loop because it's value is dynamic and will change.
+ my $valuesSize = $#values;
+
+ # Shift off each parm into @parms until we find $VAR1
+ for (my $i = 0; $i < $valuesSize; $i++) {
+ last if $values[0] =~ /^\$VAR1/;
+
+ push @parms, shift @values;
+ } # for
+
+ # Now just join the rest of the @values together
+ push @parms, join ' ', @values;
+
+ my ($err, $msg);
+
+ eval {
+ ($err, $msg) = $ccdb->$method (@parms);
+ }; # eval
+
+ if ($@) {
+ print $client "$@\n";
+ print $client "CCDB Status: 1\n";
+ next;
+ } else {
+ $msg = "Success"
+ if $msg eq '';
+ $rec = "Err:$err;Msg:$msg";
+ } # if
+ } elsif ($method =~ /^delete/i) {
+ my ($err, $msg);
+
+ eval {
+ ($err, $msg) = $ccdb->$method (@values);
+ }; # eval
+
+ if ($@) {
+ print $client "$@\n";
+ print $client "CCDB Status: 1\n";
+ next;
+ } else {
+ # A little messy here. Normally a delete method returns the number of
+ # records deleted as its status. But the caller will sense non-zero as
+ # an error. So if the $msg simply says 'Records deleted' then we flip
+ # the $err to 0.
+ $err = 0
+ if $msg eq 'Records deleted';
+
+ $rec = "Err:$err;Msg:$msg";
+ } # if
+ } # if
+ } # if
+
+ if (ref $rec eq 'HASH') {
+ if (%$rec) {
+ foreach (keys %$rec) {
+ $self->_debug ("Get: Found record");
+
+ my $data = "$_~";
+ $data .= $$rec{$_} ? $$rec{$_} : '';
+
+ print $client "$data\n";
+ } # foreach
+
+ print $client "CCDB Status: 0\n";
+ } else {
+ $self->_debug ("Get: No record found");
+
+ print $client "CCDB::$method: No record found\n";
+ print $client "CCDB Status: 1\n";
+ } # if
+ } elsif (ref $rec eq 'ARRAY') {
+ if (@$rec > 0) {
+ $self->_debug ("Find: Records found: " . scalar @$rec);
+
+ foreach my $entry (@$rec) {
+ my %rec = %$entry;
+
+ print $client '-' x 80 . "\n";
+
+ foreach (keys %rec) {
+ my $data = "$_~";
+ $data .= $rec{$_} ? $rec{$_} : '';
+
+ print $client "$data\n";
+ } # foreach
+ } # foreach
+
+ print $client '=' x 80 . "\n";
+ print $client "CCDB Status: 0\n";
+ } else {
+ $self->_debug ("Find: Records not found");
+
+ print $client "CCDB::$method: No records found\n";
+ print $client "CCDB Status: 1\n";
+ } # if
+ } elsif (ref \$rec eq 'SCALAR') {
+ my ($err, $msg);
+
+ if ($rec =~ /Err:(-*\d+);Msg:(.*)/ms) {
+ $err = $1;
+ $msg = $2;
+ } # if
+
+ print $client "$msg\n"
+ if $msg;
+ print $client "CCDB Status: $err\n";
+ } # if
+
+ $self->_debug ("Looping around for next command");
+ } # while
+
+ close $client;
+
+ $self->_verbose ("Serviced requests from $host");
+
+ return;
+} # _serviceClient
+
+sub execute ($) {
+ my ($self, $request) = @_;
+
+ return (-1, 'Unable to talk to server')
+ unless $self->{socket};
+
+ my ($status, @output) = (-1, ());
+
+ my $server = $self->{socket};
+
+ print $server "$request\n";
+
+ my $response;
+
+ while (defined ($response = <$server>)) {
+ if ($response =~ /CCDB Status: (-*\d+)/) {
+ $status = $1;
+ last;
+ } # if
+
+ push @output, $response;
+ } # while
+
+ chomp @output;
+
+ my (@recs, $output);
+
+ return ($status, \@output)
+ if $status;
+
+ if ($output[0] eq '-' x 80) {
+ shift @output;
+
+ while ($_ = shift @output) {
+ last if $_ eq '=' x 80;
+
+ my %rec;
+
+ while ($_) {
+ last if $_ eq '-' x 80;
+
+ if (/^(\S+)~(.*)$/) {
+ $rec{$1} = $2;
+ } # if
+
+ $_ = shift @output;
+ } # while
+
+ push @recs, \%rec;
+ } # while
+
+ $output = \@recs;
+ } else {
+ my %rec;
+
+ foreach (@output) {
+ if (/^(\S+):(.*)$/) {
+ $rec{$1} = $2;
+ } # if
+ } # foreach
+
+ $output = \%rec;
+ } # if
+
+ return ($status, $output);
+} # execute
+
+sub startServer (;$) {
+ my ($self, $port) = @_;
+
+ $port ||= $OPTS{CCDB_PORT};
+
+ # Create new socket to communicate to clients with
+ $self->{socket} = IO::Socket::INET->new(
+ Proto => 'tcp',
+ LocalPort => $port,
+ Listen => SOMAXCONN,
+ Reuse => 1
+ );
+
+ error "Could not create socket - $!", 1
+ unless $self->{socket};
+
+ # Announce ourselves
+ $self->_log ("Clearexec V$VERSION accepting clients at " . localtime);
+
+ # Now wait for an incoming request
+ LOOP:
+ my $client;
+
+ while ($client = $self->{socket}->accept) {
+ my $hostinfo = gethostbyaddr $client->peeraddr;
+ my $host = $hostinfo ? $hostinfo->name : $client->peerhost;
+
+ $self->_verbose ("$host is requesting service");
+
+ if ($self->getMultithreaded) {
+ $self->{server} = $$;
+
+ my $childpid;
+
+ $self->_debug ("Spawning child to handle request");
+
+ error "Can't fork: $!"
+ unless defined ($childpid = fork);
+
+ if ($childpid) {
+ $self->{pid} = $$;
+
+ $SIG{CHLD} = \&_funeral;
+ $SIG{HUP} = \&_endServer;
+ $SIG{USR2} = \&_restartServer;
+
+ $self->_debug ("Parent produced child [$childpid]");
+ } else {
+ # In child process - ServiceClient
+ $self->{pid} = $$;
+
+ $self->_debug ("Calling _serviceClient");
+ $self->_serviceClient ($host, $client);
+ $self->_debug ("Returned from _serviceClient - exiting...");
+
+ exit;
+ } # if
+ } else {
+ $self->_serviceClient ($host, $client);
+ } # if
+ } # while
+
+ # This works but I really don't like it. The parent should have looped back to
+ # the while statement thus waiting for the next client. But it doesn't seem to
+ # do that. Instead, when multithreaded, the child exits above and then the
+ # parent breaks out of the while loop. I'm not sure why this is happening.
+ # This goto fixes this up but it's sooooo ugly!
+ goto LOOP;
+} # startServer
+
+1;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<Carp>
+
+L<FindBin>
+
+L<IO::Socket|IO::Socket>
+
+L<Net::hostent|Net::hostent>
+
+L<POSIX>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ DateUtils
+ Display
+ GetConfig
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/DateUtils.pm">DateUtils</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/GetConfig.pm">GetConf</a><br>
+</blockquote>
+
+=end html
+
+=head1 SEE ALSO
+
+=begin man
+
+See also: CCDB
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=CCDB/lib/CCDB.pm">CCDB</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this module.
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2011, ClearSCM, Inc. All rights reserved.
+
+=cut
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: mspb.pl,v $
+
+MultiSite PlayBack: This script updates the CCDB database by playing back
+multisite transcations.
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.2 $
+
+=item Created:
+
+Fri Mar 11 19:09:52 PST 2011
+
+=item Modified:
+
+$Date: 2011/05/05 18:39:56 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage mspb.pl: [-u|sage] [-ve|rbose] [-deb|ug] [-vo|b <vob>]
+
+ Where:
+ -u|sage: Displays usage
+
+ -ve|rbose: Be verbose
+ -deb|ug: Output debug messages
+
+ -vo|b <vob>: Vob to process (Default: All vobs)
+
+=head1 DESCRIPTION
+
+This script updates the CCDB database with Clearcase UCM meta data by playing
+back multisite transactions.
+
+If no parameters are specified then mspb attempts to replay all transactions
+from all vobs listed in CCDB. To add a new vob use -vob. Epoch numbers are kept
+in CCDB to keep track of the last oplog operation that had been played back for
+the vob.
+
+Note that only certain transactions are played back, those that correspond to
+actions important to the metadata kept in CCDB. Also, if a transaction fails,
+i.e. the add or deletion of a record fails, then the error is silently ignored.
+This allows you to playback transactions without worry that replaying an
+already played transcation will cause the data to become out of sync. This is
+much like multisite's syncreplica itself.
+
+=cut
+
+use strict;
+use warnings;
+
+use FindBin;
+use Getopt::Long;
+
+use lib "$FindBin::Bin/lib", "$FindBin::Bin/../lib";
+
+use CCDB;
+use Clearcase;
+use Clearcase::Element;
+use Clearcase::UCM::Activity;
+use Clearcase::Vob;
+use DateUtils;
+use Display;
+use Logger;
+use TimeUtils;
+use Utils;
+
+my $VERSION = '$Revision: 1.2 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+my (%opts, %totals, $log);
+
+my $ccdb = CCDB->new;
+
+sub ParseOplog ($) {
+ my ($oplog) = @_;
+
+ my %record;
+
+ while (<$oplog>) {
+ last if /^$/;
+
+ if (/(\S+)= (.*)/) {
+ my $key = $1;
+ my $value = $2;
+
+ # Special casing op_time. For some odd reason we have more than one value
+ # on a single line. One case of this is where the keyword is "op_time".
+ # We've seen lines like this:
+ #
+ # op_time= 2008-10-15T18:48:39Z create_time= 2008-10-15T18:48:39Z
+ #
+ # So by now $value = '2008-10-15T18:48:39Z create_time= 2008-10-15T18:48:39Z'
+ # so we'll split it based on ' '.
+ if ($key eq 'op_time') {
+ # Note: 2 spaces!
+ ($value, $_) = split / /, $value;
+
+ # Set op_time
+ $record{$key} = $value;
+
+ # Now parse $create time
+ if (/(\S+)= (.*)/) {
+ $key = $1;
+ $value = $2;
+ } # if
+ } # if
+
+ # Some values are wrapped in quotes
+ if ($value =~ /(\'|\")(.*)(\'|\")/) {
+ $value = $2;
+ } # if
+
+ # If a key occurs multiple times then make its value an array
+ if ($record{$key}) {
+ if (ref $record{$key} eq 'ARRAY') {
+ push @{$record{$key}}, $value;
+ } else {
+ $record{$key} = [ $record{$key}, $value];
+ } # if
+ } else {
+ $record{$key} = $value;
+ } # if
+ } # if
+ } # while
+
+ return %record;
+} # ParseOplog
+
+sub GetSubmittedDate ($$) {
+ my ($activity, $pvob) = @_;
+
+ $pvob = Clearcase::vobtag $pvob;
+
+ my $cmd = "describe -fmt \"%Na\" activity:$activity\@$pvob";
+
+ my ($status, @output) = $Clearcase::CC->execute ($cmd);
+
+ unless ($status) {
+ if ($output[0]) {
+ foreach (split / /, $output[0]) {
+ if (/(\w+)=(.+)/) {
+ if ($1 =~ /submit_time/i) {
+ my ($year, $mon, $mday, $hour, $min, $sec) = ymdhms $2;
+ return "$year-$mon-$mday $hour:$min:$sec";
+ } # if
+ } # if
+ } # foreach
+ } # if
+ } # unless
+
+ return;
+} # GetSubmittedDate
+
+sub AddActivity ($%) {
+ my ($pvob, %oplog) = @_;
+
+ my ($cmd, $err, $status, $msg, @output, %existingRec);
+
+ $totals{'Activities processed'}++;
+
+ undef %existingRec;
+
+ # Add an activity (if not already existing)
+ %existingRec = $ccdb->GetActivity ($oplog{name_p}, $pvob);
+
+ unless (%existingRec) {
+ my $submitted = GetSubmittedDate $oplog{name_p}, $pvob;
+
+ my $cmd = "describe -fmt \"%[owner]p\" activity:$oplog{name_p}\@"
+ . Clearcase::vobtag $pvob;
+
+ my ($status, @output) = $Clearcase::CC->execute ($cmd);
+
+ ($err, $msg) = $ccdb->AddActivity ({
+ oid => $oplog{activity_oid},
+ name => $oplog{name_p},
+ pvob => $pvob,
+ owner => $output[0],
+ submitted => $submitted,
+ });
+
+ return ($err, $msg)
+ if $err;
+
+ $totals{'Activities added'}++;
+ } # unless
+
+ # Add a stream (if not already existing)
+ $cmd = "lsactivity -fmt \"%[stream]p\" $oplog{name_p}\@"
+ . Clearcase::vobtag $pvob;
+
+ ($status, @output) = $Clearcase::CC->execute ($cmd);
+
+ if ($status) {
+ # There are times when an activity is subsequently deleted. Since we are
+ # playing back Multisite transactions we will see the mkactivity first, then
+ # later see a corresponding rmactivity. Since Multisite has already played
+ # all of these transactions to Clearcase itself the activity is gone - and
+ # therefore the lsactivity will fail to find the stream. If that's the case
+ # then just return. If not then issue a warning.
+ unless ($output[0] =~ /activity not found/) {
+ $log->warn ("Can't find stream for activity:$oplog{name_p}\@"
+ . Clearcase::vobtag $pvob
+ );
+ } # unless
+
+ return (1, "Unable to execute command: $cmd (Status: $status)\n"
+ . join ("\n", @output))
+ } # if
+
+ undef %existingRec;
+
+ %existingRec = $ccdb->GetStream ($output[0], $pvob);
+
+ unless (%existingRec) {
+ ($err, $msg) = $ccdb->AddStream ({
+ name => $output[0],
+ pvob => $pvob
+ });
+
+ if ($err) {
+ $log->warn ("Unable to add stream:$output[0]\@"
+ . Clearcase::vobtag $pvob
+ . " (Error: $err)\n$msg");
+
+ return ($err, $msg);
+ } # if
+
+ $totals{'Streams added'}++;
+ } # unless
+
+ undef %existingRec;
+
+ # Link them (if not already linked)
+ %existingRec = $ccdb->GetStreamActivityXref (
+ $output[0],
+ $oplog{name_p},
+ $pvob
+ );
+
+ unless (%existingRec) {
+ ($err, $msg) = $ccdb->AddStreamActivityXref ({
+ stream => $output[0],
+ activity => $oplog{name_p},
+ pvob => $pvob,
+ });
+
+ if ($err) {
+ $log->warn ("Unable to add stream_activity_xref:$output[0]\@"
+ . Clearcase::vobtag $pvob
+ . " activity:$oplog{name_p} (Error: $err)\n$msg");
+
+ return ($err, $msg);
+ } # if
+
+ $totals{'Stream/Activity Xrefs added'}++;
+ } # unless
+
+ return;
+} # AddActivity
+
+sub AddStream ($%) {
+ my ($pvob, %oplog) = @_;
+
+ my ($err, $msg);
+
+ $totals{'Streams processed'}++;
+
+ # Add a stream (if not already existing)
+ my %existingRec = $ccdb->GetStream ($oplog{name_p}, $pvob);
+
+ unless (%existingRec) {
+ my $pvobTag = Clearcase::vobtag $pvob;
+ my $cmd = "lsstream -fmt \"%[project]p\" $oplog{name_p}\@$pvobTag";
+
+ my ($status, @output) = $Clearcase::CC->execute ($cmd);
+
+ if ($status) {
+ $log->err ("Unable to execute command: $cmd (Status: $status)"
+ . join ("\n", @output));
+ return ($status, join ("\n", @output));
+ } # if
+
+ ($err, $msg) = $ccdb->AddStream ({
+ oid => $oplog{activity_oid},
+ name => $oplog{name_p},
+ project => $output[0],
+ pvob => $pvob,
+ });
+
+ unless ($err) {
+ $totals{'Streams added'}++;
+ } # unless
+ } # unless
+
+ return ($err, $msg);
+} # AddStream
+
+sub ProcessActivity ($$%) {
+ my ($operation, $pvob, %oplog) = @_;
+
+ # Many operations in Multisite's oplog have an op of mkactivity but are
+ # actually operations on other objects based on actype_oid. The following are
+ # actype_oid values:
+ my @validActypes = (
+ 'activity',
+ 'folder',
+ 'project',
+ 'stream',
+ 'timeline',
+ 'internal',
+ );
+
+ # We only handle activity and stream here
+ my $actype;
+
+ if ($oplog{actype_oid}) {
+ $actype = $Clearcase::CC->oid2name ($oplog{actype_oid}, $pvob);
+ } else {
+ if ($operation eq 'rmactivity' and $oplog{comment}) {
+ $actype = 'activity';
+ } else {
+ return;
+ } # if
+ } # if
+
+ my ($err, $msg);
+
+ if ($operation eq 'mkactivity') {
+ if ($actype eq 'activity') {
+ AddActivity $pvob, %oplog;
+ } elsif ($actype eq 'stream') {
+ AddStream $pvob, %oplog;
+ } # if
+ } elsif ($operation eq 'rmactivity') {
+ if ($actype eq 'activity') {
+ # For rmactivity there's nothing but the comment to go on to get the
+ # activity's name. The comment must be of a format of "Destroyed activity
+ # "<activity_name>@<pvob>"." complete with nested double quotes.
+ my ($activity, $pvob);
+
+ # Note: There are rmactivity's that lack the comment! Nothing we can do
+ # with these except to ignore them!
+ return
+ unless $oplog{comment};
+
+ # Note: <pvob> is a vob tag of the variety of the client. So, for example,
+ # it can be a Windows style pvob (e.g. \\pvob) even though we are running
+ # on a Linux machine where the pvob needs to be /vob/pvob!
+ if ($oplog{comment} =~ /Destroyed activity \"activity:(\S+)\@(\S+)\"/) {
+ $activity = $1;
+ $pvob = Clearcase::vobname ($2);
+ } # if
+
+ return
+ unless ($activity or $pvob);
+
+ $totals{'Activities processed'}++;
+ $totals{'Activities deleted'}++;
+
+ return $ccdb->DeleteActivity ($activity, $pvob);
+ } elsif ($actype eq 'stream') {
+ # Note: I have yet to see an rmactivity stream with even an actype_oid!
+ $totals{'Streams processed'}++;
+ $totals{'Streams deleted'}++;
+
+ return $ccdb->DeleteStreamOID ($oplog{activity_oid});
+ } # if
+ } # if
+
+ return;
+} # ProcessActivity
+
+sub ProcessBaseline ($$%) {
+ my ($operation, $pvob, %oplog) = @_;
+
+ my ($cmd, $err, $status, $msg, @output, %existingRec);
+
+ my $pvobTag = Clearcase::vobtag $pvob;
+
+ $totals{'Baselines processed'}++;
+
+ if ($operation eq 'mkcheckpoint') {
+ undef %existingRec;
+
+ # Add an activity (if not already existing)
+ %existingRec = $ccdb->GetBaseline ($oplog{name_p}, $pvob);
+
+ unless (%existingRec) {
+ ($err, $msg) = $ccdb->AddBaseline ({
+ oid => $oplog{checkpoint_oid},
+ name => $oplog{name_p},
+ pvob => $pvob,
+ });
+
+ return ($err, $msg)
+ if $err;
+
+ $totals{'Baselines added'}++;
+ } # unless
+
+ # Add a stream_baseline_xref entry
+ $cmd = "lsbl -fmt \"%[bl_stream]p\" $oplog{name_p}\@$pvobTag";
+
+ ($status, @output) = $Clearcase::CC->execute ($cmd);
+
+ if ($status) {
+ $log->err ("Unable to execute command: $cmd (Status: $status)"
+ . join ("\n", @output));
+ return;
+ } # if
+
+ ($err, $msg) = $ccdb->AddStreamBaselineXref ({
+ stream => $output[0],
+ baseline => $oplog{name_p},
+ pvob => $pvob,
+ });
+
+ return ($err, $msg)
+ if $err;
+
+ $totals{'Stream/Baseline Xrefs added'}++;
+
+ return
+ unless $oplog{activity_oid};
+
+ # Loop through activities
+ my @activities = ref $oplog{activity_oid} eq 'ARRAY'
+ ? @{$oplog{activity_oid}}
+ : ($oplog{activity_oid});
+
+ foreach (@activities) {
+ my $activity = $Clearcase::CC->oid2name ($_, $pvob);
+
+ # I think $activity will be blank if after this mkcheckpoint somebody
+ # did an rmactivity...
+ next
+ unless $activity;
+
+ # Check to see if the activity exists
+ undef %existingRec;
+
+ %existingRec = $ccdb->GetActivity ($activity, $pvob);
+
+ unless (%existingRec) {
+ ($err, $msg) = $ccdb->AddActivity ({
+ name => $activity,
+ pvob => $pvob,
+ });
+
+ return ($err, $msg)
+ if $err;
+ } # unless
+
+ # Link them (if not already linked)
+ %existingRec = $ccdb->GetBaselineActivityXref (
+ $oplog{name_p}, $activity, $pvob
+ );
+
+ unless (%existingRec) {
+ ($err, $msg) = $ccdb->AddBaselineActivityXref ({
+ baseline => $oplog{name_p},
+ activity => $activity,
+ pvob => $pvob,
+ });
+
+ if ($err) {
+ $log->warn ("Unable to add baseline_activity_xref:$output[0]\@"
+ . "$pvobTag baseline:$oplog{name_p} activity:$_ (Error:"
+ . "$err)\n$msg");
+
+ return ($err, $msg);
+ } # if
+
+ $totals{'Baseline/Activity Xrefs added'}++;
+ } # unless
+ } # foreach
+ } elsif ($operation eq 'rmcheckpoint') {
+ $totals{'Baselines deleted'}++;
+
+ return $ccdb->DeleteBaselineOID ($oplog{checkpoint_oid});
+ } # if
+
+ return;
+} # ProcessBaseline
+
+sub ProcessElement ($$%) {
+ my ($operation, $vob, %oplog) = @_;
+
+ return
+ unless $oplog{version_oid};
+
+ my $elementVersion = $Clearcase::CC->oid2name ($oplog{version_oid}, $vob);
+ my ($element, $version) = split /$Clearcase::SFX/, $elementVersion;
+
+ # Remove VOBTAG_PREFIX from $element
+ $element = '/' . Clearcase::vobname $element;
+
+ my $cmd = "describe -fmt \"%[activity]Xp\" oid:$oplog{version_oid}\@"
+ . Clearcase::vobtag $vob;
+
+ my ($status, @output) = $Clearcase::CC->execute ($cmd);
+
+ if ($status) {
+ $log->err ("Unable to execute command: $cmd (Status: $status)"
+ . join ("\n", @output));
+ return;
+ } # if
+
+ # If this operation is not attached to an activity then we're not interested.
+ return
+ unless $output[0];
+
+ my ($activity, $pvob) = split /\@/, $output[0];
+
+ # Remove leading "activity:"
+ $activity = substr $activity, 9;
+
+ # Fix $pvob
+ $pvob = Clearcase::vobname $pvob;
+
+ my ($err, $msg, %existingRec);
+
+ if ($operation eq 'checkin'
+ or $operation eq 'checkout') {
+ %existingRec = $ccdb->GetChangeset ($activity, $element, $version, $pvob);
+
+ unless (%existingRec) {
+ my $create_time = $oplog{create_time};
+
+ # Create time from Multisite are of the format: 2008-10-15T18:48:39Z
+ $create_time =~ s/T/ /;
+ $create_time =~ s/Z//;
+
+ ($err, $msg) = $ccdb->AddChangeset ({
+ activity => $activity,
+ element => $element,
+ version => $version,
+ pvob => $pvob,
+ created => $create_time,
+ });
+
+ if ($err) {
+ $log->err ("Unable to AddChangeset ($activity, $element, $version, "
+ . "$pvob)\n$msg");
+
+ return ($err, $msg);
+ } # if
+
+ # Update Activity's submitted field (if this create time gt submitted)
+ my %activity = $ccdb->GetActivity ($activity, $pvob);
+
+ if (%activity) {
+ $activity{submitted} ||= $create_time;
+
+ if ($create_time ge $activity{submitted}) {
+ $activity{submitted} = $create_time;
+
+ my ($err, $msg) = $ccdb->UpdateActivity (
+ $activity,
+ $pvob,
+ \%activity,
+ );
+
+ $log->err ("Unable to update activity: $activity pvob: $pvob - "
+ . " submitted: $create_time")
+ if $err;
+ } # if
+ } # if
+
+ $totals{'Changesets added'}++;
+ } # unless
+ } elsif ($operation eq 'uncheckout'
+ or $operation eq 'rmver') {
+ %existingRec = $ccdb->GetChangeset ($activity, $element, $version, $pvob);
+
+ if (%existingRec) {
+ ($err, $msg) = $ccdb->DeleteChangeset (
+ $activity,
+ $element,
+ $version,
+ $pvob,
+ );
+
+ if ($err) {
+ $log->err ("Unable to DeleteChangeset ($activity, $element, $version, "
+ . "$pvob)\n$msg");
+
+ return ($err, $msg);
+ } # if
+
+ $totals{'Changesets deleted'}++;
+ } # if
+ } elsif ($operation eq 'rmelem') {
+ %existingRec = $ccdb->GetChangeset ($activity, $element, $version, $pvob);
+
+ if (%existingRec) {
+ ($err, $msg) = $ccdb->DeleteElementAll ($element);
+
+ if ($err) {
+ $log->err ("Unable to DeleteElementAll ($element)\n$msg");
+
+ return ($err, $msg);
+ } # if
+
+ $totals{'Elements removed'}++;
+ } # if
+ } # if
+
+ return;
+} # ProcessElement
+
+sub ProcessRename ($%) {
+ my ($vob, %oplog) = @_;
+
+ return
+ unless $oplog{comment};
+
+ my $object;
+
+ # Parse comment to find what got renamed and the from and to names
+ if ($oplog{comment} =~ /Changed name of (.+?) from \"(\S+)\" to \"(\S+)\"/) {
+ $object = $1;
+ my $from = $2;
+ my $to = $3;
+
+ # Only interested in these objects
+ return
+ unless $object =~ /activity/i or
+ $object =~ /baseline/i or
+ $object =~ /stream/i;
+
+ my %update = (
+ name => $to,
+ );
+
+ my $method = 'Update' . ucfirst $object;
+
+ my ($err, $str) = $ccdb->$method ($from, $vob, \%update);
+
+ if ($err) {
+ $log->err ("Unable to rename $object from $from -> $to (pvob:$vob");
+
+ return;
+ } # if;
+ } # if
+
+ if ($object eq 'activity') {
+ $totals{'Activities renamed'}++;
+ } elsif ($object eq 'baseline') {
+ $totals{'Baselines renamed'}++;
+ } elsif ($object eq 'stream') {
+ $totals{'Streams renamed'}++;
+ } # if
+
+ return;
+} # ProcessRename
+
+sub ProcessOperation ($$%) {
+ my ($operation, $vob, %oplog) = @_;
+
+ # For now let's only process the activity opcodes... We'll add more later.
+ my @interestingOpcodes = (
+ 'checkin',
+ 'checkout',
+ 'mkactivity',
+ 'mkcheckpoint',
+ 'rename',
+ 'rmactivity',
+ 'rmcheckpoint',
+ 'rmelem',
+ 'rmver',
+ 'uncheckout',
+# 'mkattr',
+# 'mkhlink',
+# 'setpvar',
+ );
+
+ return
+ unless InArray $operation, @interestingOpcodes;
+
+ if ($operation eq 'mkactivity'
+ or $operation eq 'rmactivity') {
+ return ProcessActivity ($operation, $vob, %oplog);
+ } elsif ($operation eq 'mkcheckpoint'
+ or $operation eq 'rmcheckpoint') {
+ return ProcessBaseline ($operation, $vob, %oplog);
+ } elsif ($operation eq 'checkin'
+ or $operation eq 'checkout'
+ or $operation eq 'rmelem'
+ or $operation eq 'rmver'
+ or $operation eq 'uncheckout') {
+ return ProcessElement ($operation, $vob, %oplog);
+ } elsif ($operation eq 'rename') {
+ return ProcessRename ($vob, %oplog);
+ } # if
+} # ProcessOperation
+
+sub ProcessOplog (%) {
+ my (%vob) = @_;
+
+ # Start dumpoplog off at the appropriate oplog number
+ my $cmd = 'multitool dumpoplog -long -invob '
+ . Clearcase::vobtag ($vob{name})
+ . " -from $vob{epoch}";
+
+ # Start a pipe
+ open my $oplog, "$cmd|"
+ or error "Cannot execute $cmd", 1;
+
+ my $inRecord;
+
+ while (<$oplog>) {
+ # Look for the next oplog entry
+ if (/(\d+):/) {
+ $vob{epoch} = $1;
+ $inRecord = 1;
+ next;
+ } elsif (/^$/) {
+ $inRecord = 0;
+ next;
+ } elsif (!$inRecord) {
+ next;
+ } # if
+
+ my ($operation, $status, @output);
+
+ if (/op= (\S+)/) {
+ $operation = $1;
+ } else {
+ $operation = '';
+ } # if
+
+ ProcessOperation $operation, $vob{name}, ParseOplog $oplog;
+
+ # Update vob's last_oplog
+ my ($err, $msg) = $ccdb->UpdateVob ($vob{name}, \%vob);
+
+ $log->err ("Unable to update vob:$vob{name}\'s epoch to "
+ . $vob{epoch})
+ if $err;
+ } # while
+
+ close $oplog;
+
+ return;
+} # ProcessOplog
+
+sub ProcessVob ($) {
+ my ($name) = @_;
+
+ my ($err, $msg);
+
+ my %vob = $ccdb->GetVob ($name);
+
+ $log->msg ("Processing vob:$name ($vob{type})");
+
+ unless (%vob) {
+ my $vob = Clearcase::Vob->new (Clearcase::vobtag $name);
+
+ ($err, $msg) = $ccdb->AddVob ({
+ name => $name,
+ type => $vob->vob_registry_attributes !~ /ucmvob/ ? 'base' : 'ucm',
+ });
+
+ if ($err) {
+ $log->err ("Unable to add vob $name (Error: $err)\n$msg");
+ } else {
+ $totals{'Vobs added'}++;
+ } # if
+
+ %vob = $ccdb->GetVob ($name);
+ } # unless
+
+ ProcessOplog %vob;
+} # ProcessVob
+
+sub EndProcess {
+ $totals{Errors} = $log->errors;
+ $totals{Warnings} = $log->warnings;
+
+ Stats \%totals, $log;
+} # EndProcess
+
+# Main
+local $| = 1;
+
+my $startTime = time;
+
+GetOptions (
+ \%opts,
+ 'verbose' => sub { set_verbose },
+ 'usage' => sub { Usage },
+ 'vob=s',
+) or Usage "Unknown option";
+
+$log = Logger->new;
+
+$SIG{__DIE__} = $SIG{INT} = $SIG{ABRT} = $SIG{QUIT} = $SIG{USR2} = 'EndProcess';
+
+my @vobs;
+
+if ($opts{vob}) {
+ push @vobs, $opts{vob};
+} else {
+ # Do UCM vobs first
+ my (@ucmvobs, @basevobs);
+
+ push @ucmvobs, $$_{name}
+ foreach ($ccdb->FindVob ('*', 'ucm'));
+
+ # Add on base vobs
+ push @basevobs, $$_{name}
+ foreach ($ccdb->FindVob ('*', 'base'));
+
+ push @vobs, $_ foreach (sort @ucmvobs);
+ push @vobs, $_ foreach (sort @basevobs);
+} # if
+
+if (@vobs == 1) {
+ $log->msg ('1 vob to process');
+} else {
+ $log->msg (scalar @vobs . ' vobs to process');
+} # if
+
+foreach (@vobs) {
+ ProcessVob $_;
+
+ $totals{'Vobs processed'}++;
+} # foreach
+
+display_duration $startTime, $log;
+
+$totals{Errors} = $log->errors;
+$totals{Warnings} = $log->warnings;
+
+Stats \%totals, $log;
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: Activity.pl,v $
+
+This trigger will update CCDB when activities are added or removed.
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.6 $
+
+=item Created:
+
+Fri Mar 11 17:45:57 PST 2011
+
+=item Modified:
+
+$Date: 2011/04/02 00:28:21 $
+
+=back
+
+=head1 DESCRIPTION
+
+This trigger will update the CCDB when UCM activities are added or removed. It
+is implemented as a post operation trigger on the mkactivity and rmactivity
+Clearcase operations. It should be attached to all UCM vobs (i.e. pvobs) that
+you wish CCDB to monitor. If using mktriggers.pl the trigger defintion is:
+
+ Trigger: CCDB_ACTIVITY
+ Description: Updates CCDB when activities are made or removed
+ Type: -element -all
+ Opkinds: -postop mkactivity,rmactivity,chactivity
+ ScriptEngine: Perl
+ Script: Activity.pl
+ Vobs: ucm
+ EndTrigger
+
+=cut
+
+use strict;
+use warnings;
+
+use FindBin;
+use Data::Dumper;
+
+$Data::Dumper::Indent = 0;
+
+use lib $FindBin::Bin, "$FindBin::Bin/../lib", "$FindBin::Bin/../../lib";
+
+use TriggerUtils;
+use CCDBService;
+
+my $VERSION = '$Revision: 1.6 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+triglog 'Starting trigger';
+
+TriggerUtils::dumpenv;
+
+my ($name, $pvob) = split /\@/, $ENV{CLEARCASE_ACTIVITY};
+my ($stream) = split /\@/, $ENV{CLEARCASE_STREAM};
+
+trigdie 'Activity name not known', 1
+ unless $name;
+
+trigdie 'Pvob name not known', 1
+ unless $pvob;
+
+$pvob = vobname $pvob;
+
+my $CCDBService = CCDBService->new;
+
+trigdie 'Unable to connect to CCDBService', 1
+ unless $CCDBService->connectToServer;
+
+my ($err, $msg, $request);
+
+triglog "CLEARCASE_OP_KIND: $ENV{CLEARCASE_OP_KIND}";
+
+if ($ENV{CLEARCASE_OP_KIND} eq 'mkactivity') {
+ my $activity = Dumper {
+ name => $name,
+ pvob => $pvob,
+ type => $name !~ /^(deliver|rebase|integrate|revert|tlmerge)/i
+ ? 'regular'
+ : 'integration',
+ };
+
+ # Squeeze out extra spaces
+ $activity =~ s/ = /=/g;
+ $activity =~ s/ => /=>/g;
+
+ $request = "AddActivity $activity";
+
+ triglog "Executing request: $request";
+
+ ($err, $msg) = $CCDBService->execute ($request);
+
+ trigdie "Activity: Unable to execute request: $request\n"
+ . join ("\n", @$msg), $err
+ if $err;
+
+ triglog "Success";
+
+ my $streamActivityXref = Dumper {
+ stream => $stream,
+ activity => $name,
+ pvob => $pvob,
+ };
+
+ # Squeeze out extra spaces
+ $streamActivityXref =~ s/ = /=/g;
+ $streamActivityXref =~ s/ => /=>/g;
+
+ $request = "AddStreamActivityXref $streamActivityXref"
+} elsif ($ENV{CLEARCASE_OP_KIND} eq 'rmactivity') {
+ # Note: The delete on cascade option in the MySQL database for CCDB should
+ # handle clean up of any associated records like any stream_activity_xref
+ # records.
+ $request = "DeleteActivity $name $pvob";
+} elsif ($ENV{CLEARCASE_OP_KIND} eq 'chactivity') {
+ # Need to move changeset items from $ENV{CLEARCASE_ACTIVITY} ->
+ # $ENV{CLEARCASE_TO_ACTIVITY}. I believe we will be called once for each
+ # element version since it says that CLEARCASE_ID_STR will be set and
+ # CLEARCASE_ID_STR uniquely identifies an element/version
+ triglog "Processing chactivity";
+
+ my ($fromActivity) = split /@/, $ENV{CLEARCASE_ACTIVITY};
+
+ my ($toActivity) = split /@/, $ENV{CLEARCASE_TO_ACTIVITY};
+
+ my $update = Dumper {
+ activity => $toActivity
+ };
+
+ # Squeeze out extra spaces
+ $update =~ s/ = /=/g;
+ $update =~ s/ => /=>/g;
+
+ my $elementName = $ENV{CLEARCASE_PN};
+ $elementName =~ s/\\/\//g;
+ $elementName = removeViewTag $elementName;
+ my $version = $ENV{CLEARCASE_ID_STR};
+ $version =~ s/\\/\//g;
+
+ $request = "UpdateChangeset $fromActivity $elementName ";
+ $request .= "$version $pvob $update";
+} # if
+
+triglog "Executing request: $request";
+
+($err, $msg) = $CCDBService->execute ($request);
+
+trigdie "Activity: Unable to execute request: $request\n"
+ . join ("\n", @$msg), $err
+ if $err;
+
+triglog "Success";
+
+$CCDBService->disconnectFromServer;
+
+triglog 'Ending trigger';
+
+exit 0;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<FindBin>
+
+L<Data::Dumper|Data::Dumper>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ CCDBSerivce
+ TriggerUtils
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=CCDB/lib/CCDBService.pm">CCDBService</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=CCDB/triggers/TriggerUtils.pm">TriggerUtils</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this script
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2011, ClearSCM, Inc. All rights reserved.
+
+=cut
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: Baseline.pl,v $
+
+This trigger will update CCDB when baselines are completed or removed.
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.6 $
+
+=item Created:
+
+Fri Mar 11 17:45:57 PST 2011
+
+=item Modified:
+
+$Date: 2011/04/02 00:29:15 $
+
+=back
+
+=head1 DESCRIPTION
+
+This trigger will update the CCDB when UCM baselines are completed or removed.
+It is implemented as a post operation trigger on the mkbl_complete and rmbl
+Clearcase operations. It should be attached to all UCM vobs (i.e. pvobs) that
+you wish CCDB to monitor. If using mktriggers.pl the trigger defintion is:
+
+ Trigger: CCDB_BASELINE
+ Description: Updates CCDB when baselines are completed or removed
+ Type: -element -all
+ Opkinds: -postop mkbl_complete,rmbl
+ ScriptEngine: Perl
+ Script: Baseline.pl
+ Vobs: ucm
+ EndTrigger
+
+=cut
+
+use strict;
+use warnings;
+
+use FindBin;
+use Data::Dumper;
+
+$Data::Dumper::Indent = 0;
+
+use lib $FindBin::Bin, "$FindBin::Bin/../lib", "$FindBin::Bin/../../lib";
+
+# I would like to use Clearcase but doing so causes a problem when the trigger
+# is run from Clearcase Explorer - something about my use of open3 :-(
+
+use TriggerUtils;
+use CCDBService;
+
+triglog 'Starting trigger';
+
+TriggerUtils::dumpenv;
+
+my $VERSION = '$Revision: 1.6 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+my $CCDBService = CCDBService->new;
+
+trigdie 'Unable to connect to CCDBService', 1
+ unless $CCDBService->connectToServer;
+
+my ($err, $msg, $request);
+
+triglog "CLEARCASE_OP_KIND: $ENV{CLEARCASE_OP_KIND}";
+
+foreach (split / /, $ENV{CLEARCASE_BASELINES}) {
+ my ($name, $pvob) = split /\@/;
+
+ trigdie 'Baseline name not known', 1
+ unless $name;
+
+ trigdie 'Pvob name not known', 1
+ unless $pvob;
+
+ triglog "Processing Baseline: $name\@$pvob";
+
+ my $pvobName = vobname $pvob;
+
+ if ($ENV{CLEARCASE_OP_KIND} eq 'mkbl_complete') {
+ triglog "Hit mkbl_complete!";
+
+ TriggerUtils::dumpenv;
+
+ my $cmd = "lsbl -fmt \"%[activities]p\" $name\@$pvob";
+
+ my @output = `cleartool $cmd`; chomp @output;
+ my $status = $?;
+
+ trigdie "Unable to execute $cmd (Status: $status)\n"
+ . join ("\n", @output), $status
+ if $status;
+
+ foreach my $activity (split / /, $output[0]) {
+ my $baselineActivityXref = Dumper {
+ baseline => $name,
+ activity => $activity,
+ pvob => $pvobName,
+ };
+
+ # Squeeze out extra spaces
+ $baselineActivityXref =~ s/ = /=/g;
+ $baselineActivityXref =~ s/ => /=>/g;
+
+ $request = "AddBaselineActivityXref $baselineActivityXref";
+
+ triglog "Executing the request: $request";
+
+ ($err, $msg) = $CCDBService->execute ($request);
+
+ trigdie "Baseline: Unable to execute request: $request\n"
+ . join ("\n", @$msg), $err
+ if $err;
+ } # foreach
+
+ next;
+ } elsif ($ENV{CLEARCASE_OP_KIND} eq 'mkbl') {
+ my $baseline = Dumper {
+ name => $name,
+ pvob => $pvobName,
+ };
+
+ # Squeeze out extra spaces
+ $baseline =~ s/ = /=/g;
+ $baseline =~ s/ => /=>/g;
+
+ $request = "AddBaseline $baseline";
+
+ triglog "Executing request: $request";
+
+ ($err, $msg) = $CCDBService->execute ($request);
+
+ trigdie "Unable to execute request: $request\n"
+ . join ("\n", @$msg), $err
+ if $err;
+
+ my $cmd = "lsstream -fmt \"%[activities]p\" $ENV{CLEARCASE_STREAM}";
+
+ my @output = `cleartool $cmd`; chomp @output;
+ my $status = $?;
+
+ trigdie "Unable to execute $cmd (Status: $status)\n"
+ . join ("\n", @output), $status
+ if $status;
+
+ foreach (split / /, $output[0]) {
+ my $baselineActivityXref = Dumper {
+ baseline => $name,
+ activity => $_,
+ pvob => $pvobName,
+ };
+
+ # Squeeze out extra spaces
+ $baselineActivityXref =~ s/ = /=/g;
+ $baselineActivityXref =~ s/ => /=>/g;
+
+ $request = "AddBaselineActivityXref $baselineActivityXref";
+
+ triglog "Executing request: $request";
+
+ ($err, $msg) = $CCDBService->execute ($request);
+
+ # Just ignore dups
+ trigdie "Unable to execute request: $request\n"
+ . join ("\n", @$msg), $err
+ unless $err == 0 or $err == 1062;
+ } # foreach
+
+ next;
+ } elsif ($ENV{CLEARCASE_OP_KIND} eq 'rmbl') {
+ $request = "DeleteBaseline $name $pvobName";
+ } # if
+
+ triglog "Executing request: $request";
+
+ ($err, $msg) = $CCDBService->execute ($request);
+
+ trigdie "Unable to execute request: $request\n"
+ . join ("\n", @$msg), $err
+ if $err;
+} # foreach
+
+$CCDBService->disconnectFromServer;
+
+triglog 'Ending trigger';
+
+exit 0;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<FindBin>
+
+L<Data::Dumper|Data::Dumper>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ CCDBSerivce
+ TriggerUtils
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=CCDB/lib/CCDBService.pm">CCDBService</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=CCDB/triggers/TriggerUtils.pm">TriggerUtils</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this script
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2011, ClearSCM, Inc. All rights reserved.
+
+=cut
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: Element.pl,v $
+
+This trigger will update CCDB when element versions are added or removed or
+otherwise changed. The intent of this trigger is to keep CCDB's changeset table
+up to date with respect to the element.
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.6 $
+
+=item Created:
+
+Fri Mar 11 17:45:57 PST 2011
+
+=item Modified:
+
+$Date: 2011/04/02 00:34:01 $
+
+=back
+
+=head1 DESCRIPTION
+
+This trigger will update the CCDB when element versions are added or removed. It
+is implemented as a post operation trigger on the checkin, checkout, lnname
+and rmelem as well as a pre operation trigger on checkin, uncheckout and rmver.
+This is because Clearcase creates a version that contains the string
+"CHECKEDOUT" in order to list it in the change set. Thus we add it to CCDB.
+However when a check in occurs for this element we need to remove the
+"CHECKEDOUT" record and add the newly versioned version.
+
+Also, lnname is trapped to handle when elments are moved, either through the
+cleartool move command or in the odd circumstance of orphaning an element. You
+can orphan an element in various ways. For example, if you check out a
+directory, add an element to source control (mkelem) then cancel the directory
+checkout there is no place for this new element to go! It's orphaned. In such
+cases Clearcase will move the element to the vobs lost+found directory,
+attaching the element's oid to the end of the element name.
+
+This trigger should be attached to all UCM component vobs (i.e. vobs that have
+UCM components but not pvobs) that you wish CCDB to monitor. If using
+mktriggers.pl the triggers defintion are:
+
+ Trigger: CCDB_ELEMENT_PRE
+ Description: Updates CCDB when an element's version is changed
+ Type: -element -all
+ Opkinds: -preop checkin,uncheckout,rmver
+ ScriptEngine: Perl
+ Script: Element.pl
+ Vobs: base
+ EndTrigger
+
+ Trigger: CCDB_ELEMENT_POST
+ Description: Updates CCDB when an element's version is changed
+ Type: -element -all
+ Opkinds: -postop checkin,checkout,lnname,rmelem
+ ScriptEngine: Perl
+ Script: Element.pl
+ Vobs: base
+ EndTrigger
+
+=cut
+
+use strict;
+use warnings;
+
+use FindBin;
+use File::Basename;
+use Data::Dumper;
+
+$Data::Dumper::Indent = 0;
+
+use lib $FindBin::Bin, "$FindBin::Bin/../lib", "$FindBin::Bin/../../lib";
+
+use TriggerUtils;
+use CCDBService;
+
+# I would like to use Clearcase but doing so causes a problem when the trigger
+# is run from Clearcase Explorer - something about my use of open3 :-(
+
+my $VERSION = '$Revision: 1.6 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+triglog 'Starting trigger';
+
+my ($activity, $pvob);
+
+if ($ENV{CLEARCASE_ACTIVITY}) {
+ ($activity, $pvob) = split /\@/, $ENV{CLEARCASE_ACTIVITY};
+
+ trigdie 'Activity name not known', 1
+ unless $activity;
+
+ trigdie 'Pvob name not known', 1
+ unless $pvob;
+
+ $pvob = vobname $pvob;
+} # if
+
+my ($elementName) =
+ split /$ENV{CLEARCASE_XN_SFX}/, $ENV{CLEARCASE_XPN};
+
+my ($cmd, $status, @output, $currVersion, $prevVersion);
+
+unless ($ENV{CLEARCASE_OP_KIND} eq 'rmelem') {
+ triglog "Getting current version for $elementName";
+
+ # Get the current, real version using describe;
+ $cmd = "describe -fmt \"%Vn\" $elementName";
+
+ @output = `cleartool $cmd`; chomp @output;
+ $status = $?;
+
+ trigdie "Unable to execute $cmd (Status: $status)\n"
+ . join ("\n", @output), $status
+ if $status;
+
+ $output[0] =~ s/\\/\//g;
+
+ $currVersion = $output[0];
+
+ triglog "currVersion = $currVersion";
+
+ triglog "Getting previous version for $elementName";
+
+ $cmd = "describe -fmt \"%PVn\" $elementName";
+
+ @output = `cleartool $cmd`; chomp @output;
+ $status = $?;
+
+ trigdie "Unable to execute $cmd\n"
+ . join ("\n", @output), $status
+ if $status;
+
+ $output[0] ||= '';
+
+ $output[0] =~ s/\\/\//g;
+
+ $prevVersion = $output[0];
+
+ triglog "prevVersion = $prevVersion";
+} # unless
+
+# Flip '\' -> '/'
+$elementName =~ s/\\/\//g;
+
+# Remove any trailing '/' or '/.' in $elementName
+$elementName =~ s/(.*)\/\.*$/$1/;
+
+# Collapse any '/./' -> '/'
+$elementName =~ s/\/\.\//\//g;
+
+# Remove VIEWTAG_PREFIX
+$elementName = removeViewTag $elementName;
+
+triglog "elementName: $elementName";
+
+my $CCDBService = CCDBService->new;
+
+trigdie 'Unable to connect to CCDBService', 1
+ unless $CCDBService->connectToServer;
+
+my ($err, $msg, $request);
+
+triglog "CLEARCASE_OP_KIND: $ENV{CLEARCASE_OP_KIND}";
+
+if ($ENV{CLEARCASE_OP_KIND} eq 'checkin' or
+ $ENV{CLEARCASE_OP_KIND} eq 'checkout') {
+ triglog "Processing $ENV{CLEARCASE_OP_KIND}";
+
+ # If checking in a version then we used to have a "CHECKEDOUT" version. We
+ # need to remove that if found first. Unfortunately a checkin can fail so
+ # we'll scribble on the filesystem to tell the postop to remove it.
+ if ($ENV{CLEARCASE_OP_KIND} eq 'checkin' and
+ $ENV{CLEARCASE_TRTYPE_KIND} eq 'pre-operation') {
+ exit 0
+ if $currVersion !~ /CHECKEDOUT/;
+
+ # Create a file ending in .CHECKEDOUT that indicates the version of the of
+ # the previously checked out element that we need to remove from the
+ # database in the postop. However elements can be files or directories.
+ # For a directory create a ".CHECKEDOUT" file in the directory element.
+ my $filename = $TriggerUtils::VIEWTAG_PREFIX;
+ $filename .= "$ENV{CLEARCASE_VIEW_TAG}$elementName";
+ $filename .= '/' if -d $filename;
+ $filename .= '.CHECKEDOUT';
+
+ open my $file, '>', $filename
+ or trigdie "Unable to open $filename for writing - $!", 1;
+
+ print $file "$currVersion\n";
+
+ close $file;
+
+ exit 0;
+ } else {
+ # Look for CHECKEDOUT file to indicate we must remove that from the database
+ my $checkedOutFile = $TriggerUtils::VIEWTAG_PREFIX;
+ $checkedOutFile .= "$ENV{CLEARCASE_VIEW_TAG}$elementName";
+ $checkedOutFile .= '/' if -d $checkedOutFile;
+ $checkedOutFile .= '.CHECKEDOUT';
+
+ if (-e $checkedOutFile) {
+ open my $file, '<', $checkedOutFile
+ or trigdie "Unable to open $checkedOutFile - $!", 1;
+
+ my $version = <$file>; chomp $version;
+
+ close $file;
+
+ unlink $checkedOutFile;
+
+ $request = "DeleteChangeset $activity $elementName $version $pvob";
+
+ triglog "Executing request: $request";
+
+ ($err, $msg) = $CCDBService->execute ($request);
+
+ trigdie "Unable to execute request: $request\n"
+ . join ("\n", @$msg), $err
+ if $err;
+ } # if
+
+ # Add this to the changeset
+ my $changeset = Dumper {
+ activity => $activity,
+ element => $elementName,
+ version => $currVersion,
+ pvob => $pvob,
+ };
+
+ # Squeeze out extra spaces
+ $changeset =~ s/ = /=/g;
+ $changeset =~ s/ => /=>/g;
+
+ $request = "AddChangeset $changeset";
+ } # if
+} elsif ($ENV{CLEARCASE_OP_KIND} eq 'uncheckout' or
+ $ENV{CLEARCASE_OP_KIND} eq 'rmver') {
+ triglog "Processing $ENV{CLEARCASE_OP_KIND}";
+
+ $request = "DeleteChangeset $activity $elementName $currVersion $pvob";
+} elsif ($ENV{CLEARCASE_OP_KIND} eq 'lnname') {
+ triglog "Processing $ENV{CLEARCASE_OP_KIND}";
+
+ # Exit if the previous operation (CLEARCASE_POP_KIND) was not an rmname. The
+ # user could just be doing an lnname. We want to capture only moves which, by
+ # definition need to be an rmname followed by an lnname. (What is an lnname
+ # followed by an rmname?!? The mktrtype man page is confusing on this...)
+ exit 0
+ if $ENV{CLEARCASE_POP_KIND} ne 'rmname';
+
+ # Surprisingly Clearcase does not set CLEARCASE_ACTIVITY when a move is done
+ # in a UCM context! This may be because a move in a UCM context can only be
+ # done within the context of a view set to an activity. So let's get our
+ # current activity...
+ my $cmd = 'lsactivity -cact -fmt "%Xn"';
+ my @output = `cleartool $cmd`;
+ my $status = $?;
+
+ trigdie "Unable to execute $cmd (Status: $status)\n"
+ . join ("\n", @output), $status
+ if $status;
+
+ my ($activity, $pvob) = split /\@/, $output[0];
+
+ # Remove 'activity:' from $activity
+ $activity = substr $activity, 9;
+
+ # Fix $pvob
+ $pvob = vobname $pvob;
+
+ # Fix $ENV{CLEARCASE_PN2}
+ my $oldName = $ENV{CLEARCASE_PN2};
+
+ # Switch "\"'s -> "/"'s
+ $oldName =~ s/\\/\//g;
+
+ # Remove the viewtag
+ $oldName = removeViewTag $oldName;
+
+ # Now update CCDB to reflect the move
+ my $update = Dumper {
+ element => $elementName,
+ };
+
+ # Squeeze out extra spaces
+ $update =~ s/ = /=/g;
+ $update =~ s/ => /=>/g;
+
+ triglog "Updating $oldName -> $elementName";
+
+ $request = "UpdateChangeset $activity $oldName % $pvob $update";
+} elsif ($ENV{CLEARCASE_OP_KIND} eq 'rmelem') {
+ # If we are doing rmelem then remove all traces of this element
+ triglog "Processing rmelem";
+
+ $request = "DeleteElementAll $elementName";
+} # if
+
+triglog "Executing request: $request";
+
+($err, $msg) = $CCDBService->execute ($request);
+
+trigdie "Unable to execute request: $request\n"
+ . join ("\n", @$msg), $err
+ if $err;
+
+$CCDBService->disconnectFromServer;
+
+triglog 'Ending trigger';
+
+exit 0;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<FindBin>
+
+L<Data::Dumper|Data::Dumper>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ CCDBSerivce
+ TriggerUtils
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=CCDB/lib/CCDBService.pm">CCDBService</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=CCDB/triggers/TriggerUtils.pm">TriggerUtils</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this script
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2011, ClearSCM, Inc. All rights reserved.
+
+=cut
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: Stream.pl,v $
+
+This trigger will update CCDB when streams are added or removed.
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.6 $
+
+=item Created:
+
+Fri Mar 11 17:45:57 PST 2011
+
+=item Modified:
+
+$Date: 2011/03/26 06:24:44 $
+
+=back
+
+=head1 DESCRIPTION
+
+This trigger will update the CCDB when UCM streams are added or removed. It
+is implemented as a post operation trigger on the mkstream and rmstream
+Clearcase operations. It should be attached to all UCM vobs (i.e. pvobs) that
+you wish CCDB to monitor. If using mktriggers.pl the trigger defintion is:
+
+ Trigger: CCDB_STREAM
+ Description: Updates CCDB when a stream is made or removed
+ Type: -element -all
+ Opkinds: -postop mkstream,rmstream
+ ScriptEngine: Perl
+ Script: Stream.pl
+ Vobs: ucm
+ EndTrigger
+
+=cut
+
+use strict;
+use warnings;
+
+use FindBin;
+use Data::Dumper;
+
+$Data::Dumper::Indent = 0;
+
+use lib $FindBin::Bin, "$FindBin::Bin/../lib", "$FindBin::Bin/../../lib";
+
+use TriggerUtils;
+use CCDBService;
+
+triglog 'Starting trigger';
+
+my $VERSION = '$Revision: 1.6 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+# UCM fires the mkstream trigger operation (CLEARCASE_OP_KIND=mkstream) twice,
+# once with CLEARCASE_MTYPE set to stream and another time with it set to
+# project. The reason for this is to update the project that we now have this
+# new stream. Normally we would use this to update a table in CCDB regarding
+# the relationship between UCM projects and streams, but we're not tracking that
+# so we can simply exit.
+exit 0
+ if ($ENV{CLEARCASE_MTYPE} and $ENV{CLEARCASE_MTYPE} eq 'project');
+
+my ($name, $pvob) = split /\@/, $ENV{CLEARCASE_STREAM};
+
+trigdie 'Stream name not known', 1
+ unless $name;
+
+trigdie 'Pvob name not known', 1
+ unless $pvob;
+
+$pvob = vobname $pvob;
+
+my $CCDBService = CCDBService->new;
+
+trigdie 'Unable to connect to CCDBService', 1
+ unless $CCDBService->connectToServer;
+
+my ($err, $msg, $request);
+
+triglog "CLEARCASE_OP_KIND: $ENV{CLEARCASE_OP_KIND}";
+
+if ($ENV{CLEARCASE_OP_KIND} eq 'mkstream') {
+ my $stream = Dumper {
+ name => $name,
+ pvob => $pvob
+ };
+
+ # Squeeze out extra spaces
+ $stream =~ s/ = /=/g;
+ $stream =~ s/ => /=>/g;
+
+ $request = "AddStream $stream";
+} elsif ($ENV{CLEARCASE_OP_KIND} eq 'rmstream') {
+ $request = "DeleteStream $name $pvob";
+} elsif ($ENV{CLEARCASE_OP_KIND} eq 'deliver_complete' or
+ $ENV{CLEARCASE_OP_KIND} eq 'rebase_complete') {
+ # Add $ENV{CLEARCASE_DLV_ACTS} to $ENV{CLEARCASE_BASELINES}.
+ $ENV{CLEARCASE_DLVR_ACTS} ||= '';
+
+ foreach (split / /, $ENV{CLEARCASE_DLVR_ACTS}) {
+ my ($activity) = split /\@/;
+
+ foreach (split / /, $ENV{CLEARCASE_BASELINES}) {
+ my ($baseline) = split /\@/;
+
+ my $baselineActivityXref = Dumper {
+ baseline => $baseline,
+ activity => $activity,
+ pvob => $pvob,
+ };
+
+ # Squeeze out extra spaces
+ $baselineActivityXref =~ s/ = /=/g;
+ $baselineActivityXref =~ s/ => /=>/g;
+
+ $request = "AddBaselineActivityXref $baselineActivityXref";
+
+ triglog "Executing request: $request";
+
+ ($err, $msg) = $CCDBService->execute ($request);
+
+ # Just ignore dups
+ trigdie "Unable to execute request: $request\n"
+ . join ("\n", @$msg), $err
+ unless $err == 0 or $err == 1062;
+ } # foreach
+ } # foreach
+
+ exit 0;
+} # if
+
+triglog "Executing request: $request";
+
+($err, $msg) = $CCDBService->execute ($request);
+
+trigdie "Unable to execute request: $request\n"
+ . join ("\n", @$msg), $err
+ if $err;
+
+$CCDBService->disconnectFromServer;
+
+triglog 'Ending trigger';
+
+exit 0;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<FindBin>
+
+L<Data::Dumper|Data::Dumper>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ CCDBSerivce
+ TriggerUtils
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=CCDB/lib/CCDBService.pm">CCDBService</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=CCDB/triggers/TriggerUtils.pm">TriggerUtils</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this script
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2011, ClearSCM, Inc. All rights reserved.
+
+=cut
+
--- /dev/null
+=pod
+
+=head1 NAME $RCSfile: TriggerUtils.pm,v $
+
+Trigger Utilities
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.3 $
+
+=item Created
+
+Fri Mar 11 15:37:34 PST 2011
+
+=item Modified
+
+$Date: 2011/03/26 06:24:30 $
+
+=back
+
+=head1 SYNOPSIS
+
+Provides an some utilities for the CCDB Triggers.
+
+=cut
+
+package TriggerUtils;
+
+use strict;
+use warnings;
+
+use Carp;
+use FindBin;
+
+use lib "$FindBin::Bin/../../lib";
+
+use DateUtils;
+
+use base 'Exporter';
+
+our $VIEW_DRIVE = 'M';
+our $VIEWTAG_PREFIX = ($^O =~ /mswin/i or $^O =~ /cygwin/)
+ ? "$VIEW_DRIVE:/"
+ : "/view/";
+
+our @EXPORT = qw (
+ trigmsg
+ triglog
+ triglogmsg
+ trigdie
+ vobname
+);
+
+our $logfile;
+
+my $logfileName = "$FindBin::Bin/trigger.log";
+
+sub trigmsg ($){
+ # Display a message to the user using clearprompt
+ my ($msg) = @_;
+
+ my $cmd = "clearprompt proceed -newline -type error -prompt \"$msg\" ";
+ $cmd .= "-mask abort -default abort";
+
+ `$cmd`;
+
+ return;
+} # trigmsg
+
+sub triglog ($) {
+ # Log a message to the log file
+ my ($msg) = @_;
+
+ return unless $ENV{CCDB_TRIGGER_DEBUG};
+
+ unless ($logfile) {
+ open $logfile, '>>', $logfileName
+ or die "Unable to open logfile $logfile - $!\n";
+
+ $logfile->autoflush (1);
+ } # unless
+
+ my $timestamp = timestamp;
+
+ print $logfile "$FindBin::Script: $timestamp: $msg\n";
+
+ return;
+} # triglog
+
+sub triglogmsg ($) {
+ my ($msg) = @_;
+
+ # Log message to log file then display it to user
+ triglog $msg;
+ trigmsg $msg;
+
+ return;
+} # triglogmsg
+
+sub trigdie ($$) {
+ my ($msg, $err) = @_;
+
+ $err ||= 0;
+
+ triglog $msg;
+ die "$msg\n";
+} # trigdie
+
+sub vobname ($) {
+ my ($pvob) = @_;
+
+ # CCDB stores pvob's in the database with the VOBTAG_PREFIX removed. This
+ # makes a vob name OS independent as on Windows it's \$pvob and Unix/Linux
+ # it's /vob/$pvob (or sometimes /vobs/$pvob! This is site specific). Now we
+ # have a handy method in Clearcase.pm for this but we want speed here. Doing a
+ # "use Clearcase;" will invoke a cleartool subproccess ($Clearcase::CC) and we
+ # don't want that overhead. So we are replicating that code here. We are
+ # hinging off of the first character of the vob name (either '\', or '/') to
+ # indicate if we are Windows or non-Windows. Additionally we are hardcoding
+ # '/vob/' as the vob tag prefix for the Unix/Linux case.
+ if (substr ($pvob, 0, 1) eq '\\') {
+ $pvob = substr $pvob, 1;
+ } elsif (substr ($pvob, 0, 1) eq '/') {
+ if ($pvob =~ /\/vob\/(.+)/) {
+ $pvob = $1;
+ } # if
+ } # if
+
+ return $pvob;
+} # vobname
+
+sub dumpenv () {
+ triglog 'Dumping CLEARCASE_* environment';
+
+ foreach (keys %ENV) {
+ next unless /CLEARCASE_/;
+
+ triglog "$_: $ENV{$_}";
+ } # foreach
+
+ return;
+} # dumpenv
+
+1;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<Carp>
+
+L<FindBin>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ DateUtils
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/DateUtils.pm">DateUtils</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this module
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2011, ClearSCM, Inc. All rights reserved.
+
+=cut
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: update.pl,v $
+
+Updates the CCDB database
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.4 $
+
+=item Created:
+
+Fri Mar 11 19:09:52 PST 2011
+
+=item Modified:
+
+$Date: 2011/05/05 18:37:05 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage update.pl: [-u|sage] [-ve|rbose] [-deb|ug]
+
+ [-vo|b <vob>]
+
+ [[-p|vob <pvob>]|
+ [[-p|vob <pvob> -a|ctivity <activity>]|
+ [-p|vob <pvob> -b|aseline <baseline>]|
+ [-p|vob <pvob> -s|tream <stream>]]]
+
+ [-o|plog [<vob>]]
+
+ [-c|heckchangesets]
+
+ Where:
+ -u|sage: Displays usage
+
+ -ve|rbose: Be verbose
+ -deb|ug: Output debug messages
+
+ -vo|b <vob>: Vob to process
+
+ -p|vob <pvob>: PVOB to operate on
+ -a|ctivity <activity>: Activity to process
+ -b|aseline <baseline>: Baseline to process
+ -s|tream <stream>: Stream to process
+
+ -o|plog [<vob>]: Process oplog (Default: All vobs)
+
+ -ch
+
+=head1 DESCRIPTION
+
+This script updates the CCDB database with Clearcase UCM meta data. It operates
+in 2 modes.
+
+=head2 Update mode
+
+In this mode, indicated by specifying either no options or a -pvob and
+optionally one of -activity, -baseline or -stream, update.pl will query
+Clearcase and gather all metadata for the specified option.
+
+You can run update.pl with no paramters to process all pvobs in the current
+registry region of you can specify a -pvob to process. This is generally how
+the script is run. Note you can parallelize update.pl by running it multiple
+times each with its own -pvob. In this case the script will log activity to
+update.<pvob>.log.
+
+Or you can run "fix ups" to add individual activities, baselines or streams by
+specifying -activity (or -baseline/-stream) and its -pvob. Note however that
+the object is not validated (In such cases we don't check that say activity and
+pvob are valid - we just add them to the database).
+
+Additionally you can use -vob to add a vob to CCDB. This should be a relatively
+infrequent operation and it is necessary to add vobs that -oplog will process.
+
+=head2 Check Change Sets mode
+
+Even with this script initially popullating CCDB and with the appropriate
+triggers set to fire to keep CCDB up to date, and even with -oplog mode to apply
+changes from other sites the CCDB may still become out of sync with Clearcase.
+This is due to the fact that orphaned files can effect change set membership in
+UCM and Clearcase does not call any triggers or otherwise notify you of the
+problem. To illustrate, if the user is running under UCM and checks out a
+directory, makes an element and checks it in, but then cancels the checkout of
+the directory, Clearcase is forced to orphan the file by placing it in
+lost+found. A warning is issued to the user, however no triggers are called.
+
+Investigating the change set we see that the elements that were orphaned are
+indicated in the change set but their paths have been altered to indicate that
+the elements are in lost+found! One would think that Clearcase would fire the
+chactivity trigger but it seems that trigger is only fired when elements change
+from one activity to another. In this case the elements are changing, but the
+activity is the same activity. To me this is a bug and Clearcase should fire the
+chactivity trigger with CLEARCASE_ACTIVITY == CLEARCASE_TO_ACTIVITY. If this
+were the case we could handle this situation with triggers.
+
+Check change set mode instead goes through all of the changesets in CCDB and
+verifies that the changeset in CCDB matches the changeset as listed by
+lsactivity -long. If not it updates it. This is an intense activity that will
+be time consuming but I can see no other way to fix up this problem.
+
+=cut
+
+use strict;
+use warnings;
+
+use FindBin;
+use Getopt::Long;
+
+use lib "$FindBin::Bin/lib", "$FindBin::Bin/../lib";
+
+use CCDB;
+use Clearcase;
+use Clearcase::Vob;
+use Clearcase::UCM;
+use Clearcase::UCM::Activity;
+use Clearcase::Element;
+use Display;
+use Logger;
+use TimeUtils;
+use Utils;
+
+my $VERSION = '$Revision: 1.4 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+my (%opts, %totals, $log);
+
+my $ccdb = CCDB->new;
+
+# Forwards
+sub ProcessFolder ($$);
+
+sub changeset ($$) {
+ my ($activity, $pvob) = @_;
+
+ $pvob = Clearcase::vobtag $pvob;
+
+ my $cmd = "lsact -fmt \"%[versions]CQp\" $activity\@$pvob";
+
+ my ($status, @output) = $Clearcase::CC->execute ($cmd);
+
+ $log->err ("Unable to execute $cmd\n" . join ("\n", @output), $status)
+ if $status;
+
+ # Need to split up change set. It's presented to us as quoted and space
+ # separated however the change set elements themselves can have spaces in
+ # them! e.g.:
+ #
+ # "/vob/foo/file name with spaces@@/main/1", "/vob/foo/file name2@@/main/2"
+ #
+ # So we'll split on '", ""'! Note that this will leave us with the first
+ # element with a leading '"' and the last element with a trailing '"' which
+ # we will have to handle.
+ #
+ # Additionally we will call collapseOverExtendedViewPathname to normalize
+ # the over extended pathnames to element hashes.
+ my (@changeset);
+
+ @output = split /\", \"/, $output[0]
+ if $output[0];
+
+ foreach (@output) {
+ # Skip any cleartool warnings. We are getting warnings of the form:
+ # "A version in the change set of activity "63332.4" is currently
+ # unavailable". Probably some sort of subtle corruption that we can ignore.
+ # (It should be fixed but we aren't going to be doing that here!)
+ next if /cleartool: Warning/;
+
+ # Strip any remaining '"'s
+ s/^\"//; s/\"$//;
+
+ # Remove vob prefix but keep the leading "/"
+ $_ = '/' . Clearcase::vobname $_;
+
+ my %element = Clearcase::Element::collapseOverExtendedVersionPathname $_;
+
+ push @changeset, \%element;
+ } # foreach
+
+ return @changeset;
+} # changeset
+
+sub baselineActivities (%) {
+ my (%baseline) = @_;
+
+ my $pvobTag = Clearcase::vobtag $baseline{pvob};
+
+ my $cmd = "lsbl -fmt \"%[activities]p\" $baseline{name}\@$pvobTag";
+
+ my ($status, @output) = $Clearcase::CC->execute ($cmd);
+
+ $log->err ("Unable to execute $cmd\n" . join ("\n", @output), $status)
+ if $status;
+
+ $output[0] ||= '';
+
+ return split / /, $output[0];
+} # baselineActivities
+
+sub UpdatePvob ($) {
+ my ($pvob) = @_;
+
+ my %pvob = $ccdb->GetVob ($pvob);
+
+ return if %pvob;
+
+ my ($err, $msg) = $ccdb->AddVob ({
+ name => $pvob,
+ type => 'ucm',
+ });
+
+ if ($err) {
+ $log->err ("Unable to add pvob:$pvob\n$msg");
+ } else {
+ $totals{'Pvobs added'}++;
+
+ $log->msg ("Added pvob:$pvob");
+ } # if
+
+ return;
+} # UpdatePvob
+
+sub UpdateFolder ($$) {
+ my ($folder, $pvob) = @_;
+
+ my %folder = $ccdb->GetFolder ($folder, $pvob);
+
+ return if %folder;
+
+ my ($err, $msg) = $ccdb->AddFolder ({
+ name => $folder,
+ pvob => $pvob,
+ });
+
+ if ($err) {
+ $log->err ("Unable to add folder:$folder\n$msg");
+ } else {
+ $totals{'Folders added'}++;
+
+ $log->msg ("Added folder:$folder");
+ } # if
+
+ return;
+} # UpdateFolder
+
+sub UpdateSubfolder ($$$) {
+ my ($parent, $subfolder, $pvob) = @_;
+
+ my %subfolder = $ccdb->GetSubfolder ($parent, $subfolder, $pvob);
+
+ return if %subfolder;
+
+ my ($err, $msg) = $ccdb->AddSubfolder ({
+ parent => $parent,
+ subfolder => $subfolder,
+ pvob => $pvob,
+ });
+
+ if ($err) {
+ $log->err ("Unable to add subfolder:$parent/$subfolder\n$msg");
+ } else {
+ $totals{'Subfolders added'}++;
+
+ $log->msg ("Added subfolder:$parent/$subfolder");
+ } # if
+
+ return;
+} # UpdateSubfolder
+
+sub UpdateProject ($$$) {
+ my ($project, $folder, $pvob) = @_;
+
+ my %project = $ccdb->GetProject ($project, $folder, $pvob);
+
+ return if %project;
+
+ my ($err, $msg) = $ccdb->AddProject ({
+ name => $project,
+ folder => $folder,
+ pvob => $pvob,
+ });
+
+ if ($err) {
+ $log->err ("Unable to add project:$project folder:$folder pvob:$pvob\n$msg");
+ } else {
+ $totals{'Projects added'}++;
+
+ $log->msg ("Added Project:$project");
+ } # if
+
+ return;
+} # UpdateProject
+
+sub UpdateStream ($$) {
+ my ($name, $pvob) = @_;
+
+ my %stream = $ccdb->GetStream ($name, $pvob);
+
+ return if %stream;
+
+ # Determine the integration stream for this stream's project. First get
+ # project for the stream.
+ my $pvobTag = Clearcase::vobtag ($pvob);
+
+ my $cmd = "lsstream -fmt \"%[project]p\" $name\@$pvobTag";
+
+ my ($status, @output) = $Clearcase::CC->execute ($cmd);
+
+ if ($status) {
+ $log->err ("Unable to execute $cmd\n" . join ("\n", @output));
+
+ return;
+ } # if
+
+ # Now get the intergration stream for this project
+ $cmd = "lsproject -fmt \"%[istream]p\" $output[0]\@$pvobTag";
+
+ ($status, @output) = $Clearcase::CC->execute ($cmd);
+
+ if ($status) {
+ $log->err ("Unable to execute $cmd\n" . join ("\n", @output));
+
+ return;
+ } # if
+
+ my $type = 'integration'
+ if $name eq $output[0];
+
+ my ($err, $msg) = $ccdb->AddStream ({
+ name => $name,
+ pvob => $pvob,
+ type => $type,
+ });
+
+ if ($err) {
+ $log->err ( "Unable to add stream:$name\n$msg");
+ } else {
+ $log->msg ("Added stream:$name");
+ $totals{'Streams added'}++;
+ } # if
+} # UpdateStream
+
+sub UpdateChangeset ($$$) {
+ my ($activity, $pvob, $element) = @_;
+
+ my %element = (
+ name => '/' . Clearcase::vobname $element->pname,
+ version => $element->version,
+ );
+
+ my %changeset = $ccdb->GetChangeset (
+ $activity,
+ '/' . Clearcase::vobname $element->pname,
+ $element->version,
+ $pvob,
+ );
+
+ return if %changeset;
+
+ my ($err, $msg) = $ccdb->AddChangeset ({
+ activity => $activity,
+ element => $element{name},
+ version => $element{version},
+ pvob => $pvob,
+
+ });
+
+ if ($err) {
+ $log->err ("Unable to add changeset activity:$activity "
+ . "element:$element{name}$Clearcase::SFX$element{version}\n$msg");
+ } else {
+ $totals{'Changesets added'}++;
+
+ $log->msg ("Linked activity:$activity -> element:$element{name}");
+ } # if
+
+ return;
+} # UpdateChangeset
+
+sub UpdateActivity ($$) {
+ my ($name, $pvob) = @_;
+
+ my %activity = $ccdb->GetActivity ($name, $pvob);
+
+ return if %activity;
+
+ my ($err, $msg) = $ccdb->AddActivity ({
+ name => $name,
+ pvob => $pvob,
+ });
+
+ if ($err) {
+ $log->err ("Unable to add activity:$name\n$msg");
+ } else {
+ $totals{'Activities added'}++;
+
+ $log->msg ("Added activity $name");
+ } # if
+
+ return;
+} # UpdateActivity
+
+sub UpdateBaselineActivityXref (%) {
+ my (%baseline) = @_;
+
+ $log->msg ("Processing Baseline Activities for $baseline{name}");
+
+ my %baselineActivityXref = (
+ baseline => $baseline{name},
+ pvob => $baseline{pvob},
+ );
+
+ foreach (baselineActivities %baseline) {
+ my ($err, $msg);
+
+ # Often activities in a baseline have not yet been added so add them here.
+ # (Not sure why this is the case...)
+
+ my %existingRec = $ccdb->GetActivity ($_, $baseline{pvob});
+
+ UpdateActivity $_, $baseline{pvob}
+ unless %existingRec;
+
+ $baselineActivityXref{activity} = $_;
+
+ %existingRec = $ccdb->GetBaselineActivityXref (
+ $baselineActivityXref{baseline},
+ $baselineActivityXref{activity},
+ $baselineActivityXref{pvob}
+ );
+
+ unless (%existingRec) {
+ ($err, $msg) = $ccdb->AddBaselineActivityXref (\%baselineActivityXref);
+
+ if ($err) {
+ $log->err ("Unable to add baseline:$baselineActivityXref{name}"
+ . " activity: $baselineActivityXref{activity}\n"
+ . $msg
+ );
+ } else {
+ $totals{'Baseline Activity Xrefs added'}++;
+ } # if
+ } # unless
+ } # foreach
+
+ $log->msg ("Processed Baseline Activities for $baseline{name}");
+
+ return;
+} # UpdateBaselineActivityXref
+
+sub UpdateBaseline ($$) {
+ my ($name, $pvob) = @_;
+
+ my %baseline = $ccdb->GetBaseline ($name, $pvob);
+
+ return if %baseline;
+
+ my ($err, $msg) = $ccdb->AddBaseline ({
+ name => $name,
+ pvob => $pvob,
+ });
+
+ if ($err) {
+ $log->err ("Unable to add baseline:$name\n$msg");
+ } else {
+ $totals{'Baselines added'}++;
+
+ $log->msg ("Added baseline:$name");
+
+ my %baseline = $ccdb->GetBaseline ($name, $pvob);
+
+ UpdateBaselineActivityXref (%baseline);
+ } # if
+
+ return;
+} # Updatebaseline
+
+sub UpdateStreamActivityXref ($$$) {
+ my ($stream, $activity, $pvob) = @_;
+
+ my %streamActivityXref = $ccdb->GetStreamActivityXref (
+ $stream,
+ $activity,
+ $pvob,
+ );
+
+ return if %streamActivityXref;
+
+ my ($err, $msg) = $ccdb->AddStreamActivityXref ({
+ stream => $stream,
+ activity => $activity,
+ pvob => $pvob,
+ });
+
+ if ($err) {
+ $log->err ("Unable to add stream_activity_xref stream:$stream "
+ . "activity:$activity\n$msg");
+ return;
+ } else {
+ $totals{'Stream Activity Xrefs added'}++;
+
+ $log->msg ("Linked stream:$stream -> activity:$activity");
+ } # if
+
+ return;
+} # UpdateStreamActivityXref
+
+sub ProcessElements ($$) {
+ my ($name, $pvob) = @_;
+
+ $log->msg ("Finding changeset for activity:$name");
+
+ my $activity = Clearcase::UCM::Activity->new ($name, $pvob);
+
+ foreach ($activity->changeset) {
+ my ($element) = $_;
+
+ # Remove vob prefix but keep the leading "/"
+ my $elementName = '/' . Clearcase::vobname $element->pname;
+
+ $log->msg (
+ "Processing element:$elementName"
+ . $Clearcase::SFX
+ . $element->version
+ );
+
+ UpdateChangeset $name, $pvob, $element;
+ } # foreach;
+
+ $log->msg ("Processed changeset for activity:$name");
+
+ return;
+} # ProcessElements
+
+sub ProcessActivities ($$) {
+ my ($stream, $pvob) = @_;
+
+ $log->msg ("Finding activities in stream:$stream");
+
+ my $pvobTag = Clearcase::vobtag ($pvob);
+
+ my $cmd = "lsstream -fmt \"%[activities]p\" $stream\@$pvobTag";
+
+ my ($status, @output) = $Clearcase::CC->execute ($cmd);
+
+ if ($status) {
+ $log->err ("Unable to execute $cmd\n" . join ("\n", @output), $status);
+
+ return;
+ } # if
+
+ $output[0] ||= '';
+
+ foreach (sort split / /, $output[0]) {
+ next if /^DEFAULT.*NO_CHECKIN/;
+
+ UpdateActivity ($_, $pvob);
+
+ $totals{'Activities processed'}++;
+
+ UpdateStreamActivityXref $stream, $_, $pvob;
+
+ ProcessElements $_, $pvob;
+ } # foreach
+
+ $log->msg ("Processed activities in stream:$stream");
+
+ return;
+} # ProcessActivities
+
+sub ProcessBaselines ($$) {
+ my ($stream, $pvob) = @_;
+
+ $log->msg ("Finding baselines in stream:$stream");
+
+ my $pvobTag = Clearcase::vobtag ($pvob);
+
+ my $cmd = "lsbl -stream $stream\@$pvobTag -short";
+
+ my ($status, @baselines) = $Clearcase::CC->execute ($cmd);
+
+ if ($status) {
+ $log->err ("Unable to execute $cmd\n" . join ("\n", @baselines));
+
+ return;
+ } # if
+
+ foreach (sort @baselines) {
+ UpdateBaseline ($_, $pvob);
+
+ $totals{'Baselines processed'}++;
+ } # foreach
+
+ $log->msg ("Processed baselines in stream:$stream");
+
+ return;
+} # ProcessBaselines
+
+sub ProcessStream ($$) {
+ my ($name, $pvob) = @_;
+
+ $totals{'Streams processed'}++;
+
+ UpdateStream $name, $pvob;
+
+ ProcessActivities $name, $pvob;
+ ProcessBaselines $name, $pvob;
+
+ return;
+} # ProcessStream
+
+sub ProcessProject ($$$) {
+ my ($project, $folder, $pvob) = @_;
+
+ my $pvobTag = Clearcase::vobtag $pvob;
+
+ $log->msg ("Processing project:$project\@$pvobTag");
+
+ UpdateProject ($project, $folder, $pvob);
+
+ my $cmd = "lsstream -short -in $project\@$pvobTag";
+
+ my ($status, @output) = $Clearcase::CC->execute ($cmd);
+
+ if ($status) {
+ $log->err ("Unable to execute $cmd\n" . join ("\n", @output));
+
+ return;
+ } # if
+
+ foreach (@output) {
+ ProcessStream $_, $pvob;
+ } # foreach
+
+ return;
+} # ProcessProject
+
+sub ProcessFolder ($$) {
+ my ($folder, $pvob) = @_;
+
+ my $pvobTag = Clearcase::vobtag $pvob;
+
+ $log->msg ("Processing folder:$folder\@$pvobTag");
+
+ UpdateFolder ($folder, $pvob);
+
+ my $cmd = "lsfolder -fmt \"%[contains_folders]p\" $folder\@$pvobTag";
+
+ my ($status, @output) = $Clearcase::CC->execute ($cmd);
+
+ if ($status) {
+ $log->err ("Unable to execute command $cmd (Status: $status)\n"
+ . join ("\n", @output), 1);
+
+ return;
+ } # if
+
+ $output[0] ||= '';
+
+ foreach (split / /, $output[0]) {
+ ProcessFolder $_, $pvob;
+
+ UpdateSubfolder ($folder, $_, $pvob);
+ } # foreach
+
+ $cmd = "lsfolder -fmt \"%[contains_projects]p\" $folder\@$pvobTag";
+
+ ($status, @output) = $Clearcase::CC->execute ($cmd);
+
+ if ($status) {
+ $log->err ("Unable to execute command $cmd (Status: $status)\n"
+ . join ("\n", @output), 1);
+
+ return;
+ } # if
+
+ $output[0] ||= '';
+
+ foreach (split / /, $output[0]) {
+ ProcessProject $_, $folder, $pvob;
+ } # foreach
+
+ return;
+} # ProcessFolder
+
+sub ProcessPvob ($) {
+ my ($pvobName) = @_;
+
+ $log->msg ("Processing pvob:$pvobName");
+
+ UpdatePvob $pvobName;
+
+ ProcessFolder ('RootFolder', $pvobName);
+
+ return;
+
+ $log->msg ("Finding streams in pvob:$pvobName");
+
+ my $pvob = Clearcase::vobtag ($pvobName);
+
+ my $cmd = "lsstream -invob $pvob -short";
+ my ($status, @streams) = $Clearcase::CC->execute ($cmd);
+
+ $log->err ("Unable to execute $cmd\n" . join ("\n", @streams), $status)
+ if $status;
+
+ my %stream = (
+ pvob => $pvobName,
+ );
+
+ foreach (sort @streams) {
+ $stream{name} = $_;
+
+ $totals{'Streams processed'}++;
+
+ ProcessStream $stream{name}, $stream{pvob};
+ } # foreach
+
+ $totals{'Pvobs processed'}++;
+
+ $log->msg ("Finished processing pvob:$pvobName");
+
+ return;
+} # ProcessPvob
+
+sub ProcessVob ($) {
+ my ($name) = @_;
+
+ my ($err, $msg);
+
+ my %existingRec = $ccdb->GetVob ($name);
+
+ unless (%existingRec) {
+ my $vob = Clearcase::Vob->new (Clearcase::vobtag $name);
+
+ # If vob doesn't exist then $vob is just an empty shell. Check to see if
+ # another field is present to make sure the vob really exists. A vob should
+ # always have a region, for example.
+ return
+ unless $vob->region;
+
+ my $vobRegistryAttributes = $vob->vob_registry_attributes;
+
+ my $type = ($vobRegistryAttributes and
+ $vobRegistryAttributes =~ /ucmvob/) ? 'ucm' : 'base';
+
+ ($err, $msg) = $ccdb->AddVob ({
+ name => $name,
+ type => $type,
+ });
+
+ if ($err) {
+ $log->err ("Unable to add vob $name (Error: $err)\n$msg");
+ } else {
+ $totals{'Vobs added'}++;
+ } # if
+ } # unless
+
+ return;
+} # ProcessVob
+
+# Main
+local $| = 1;
+
+my $startTime = time;
+
+GetOptions (
+ \%opts,
+ 'verbose' => sub { set_verbose },
+ 'usage' => sub { Usage },
+ 'activity=s',
+ 'baseline=s',
+ 'checkchangeset',
+ 'pvob=s',
+ 'stream=s',
+ 'vob=s',
+) or Usage "Unknown option";
+
+my $nbrOpts = 0;
+
+$nbrOpts++ if $opts{pvob};
+$nbrOpts++ if $opts{activity};
+$nbrOpts++ if $opts{baseline};
+$nbrOpts++ if $opts{stream};
+$nbrOpts++ if $opts{vob};
+
+Usage "Cannot specify -checkchangeset and any other options"
+ if $opts{checkchangeset} and $nbrOpts != 0;
+
+Usage "Cannot specify -vob and any other options"
+ if $opts{vob} and ($nbrOpts != 1 or $opts{checkchangeset});
+
+my $me = $FindBin::Script;
+ $me =~ s/\.pl$//;
+
+if ($opts{activity} and $opts{pvob} and
+ ($opts{baseline} or $opts{stream})) {
+ Usage "If -activity is specified then -pvob should be the only other "
+ . "option";
+ exit 1;
+} elsif ($opts{baseline} and $opts{pvob} and
+ ($opts{activity} or $opts{stream})) {
+ Usage "If -baseline is specified then -pvob should be the only other "
+ . "option";
+ exit 1;
+} elsif ($opts{stream} and $opts{pvob} and
+ ($opts{activity} or $opts{baseline})) {
+ Usage "If -stream is specified then -pvob should be the only other option";
+ exit 1;
+} elsif ($opts{pvob}) {
+ $nbrOpts = 0;
+
+ $nbrOpts++ if $opts{activity};
+ $nbrOpts++ if $opts{baseline};
+ $nbrOpts++ if $opts{stream};
+
+ if ($nbrOpts != 0 and $nbrOpts > 1) {
+ Usage "If -pvob is specified then it must be used alone or in "
+ . "conjunction\nwith only one of -activity, -baseline or -stream "
+ . "must be specified\n";
+ exit 1;
+ } # fi
+} # if
+
+if ($opts{activity} and $opts{pvob}) {
+ $log = Logger->new;
+
+ $log->msg ("$FindBin::Script V$VERSION");
+
+ UpdateActivity ($opts{activity}, $opts{pvob});
+} elsif ($opts{baseline} and $opts{pvob}) {
+ $log = Logger->new;
+
+ $log->msg ("$FindBin::Script V$VERSION");
+
+ UpdateBaseline ($opts{baseline}, $opts{pvob});
+} elsif ($opts{stream} and $opts{pvob}) {
+ $log = Logger->new;
+
+ $log->msg ("$FindBin::Script V$VERSION");
+
+ UpdateStream ($opts{stream}, $opts{pvob});
+} elsif ($opts{pvob}) {
+ $log = Logger->new (name => "$me.$opts{pvob}");
+
+ $log->msg ("$FindBin::Script V$VERSION");
+
+ ProcessPvob $opts{pvob};
+} elsif ($opts{checkchangeset}) {
+ error "The -checkchangeset option is not implemented yet", 1;
+} elsif ($opts{vob}) {
+ $log = Logger->new;
+
+ $log->msg ("$FindBin::Script V$VERSION");
+
+ ProcessVob $opts{vob};
+} else {
+ $log = Logger->new;
+
+ my $UCM = Clearcase::UCM->new;
+
+ $log->msg ("$FindBin::Script V$VERSION");
+
+ ProcessPvob $_
+ foreach ($UCM->pvobs);
+} # if
+
+display_duration $startTime, $log;
+
+$totals{Errors} = $log->errors;
+
+Stats \%totals, $log;
--- /dev/null
+################################################################################
+#
+# File: $RCSfile: Makefile,v $
+# Revision: $Revision: 1.8 $
+# Description: Makefile for Clearscm
+# Author: Andrew@Clearscm.com
+# Created: Mon Nov 13 16:14:30 1995
+# Modified: $Date: 2012/09/20 06:52:37 $
+# Language: Makefile
+#
+# (c) Copyright 2010, ClearSCM, Inc., all rights reserved.
+#
+################################################################################
+CLEARLIB = etc/mail.conf\
+ lib/CmdLine.pm\
+ lib/BinMerge.pm\
+ lib/DateUtils.pm\
+ lib/Display.pm\
+ lib/GetConfig.pm\
+ lib/Logger.pm\
+ lib/Machines.pm\
+ lib/Mail.pm\
+ lib/OSDep.pm\
+ lib/Rexec.pm\
+ lib/TimeUtils.pm\
+ lib/Utils.pm
+CLEARCC = lib/Clearcase.pm\
+ lib/Clearcase
+CLEARCQ = etc/cq.conf\
+ lib/Clearquest.pm\
+ lib/Clearquest
+CLEARADM = clearadm
+CLEARENV = rc
+CLEARAGENT = lib/Display.pm\
+ lib/OSDep.pm\
+ lib/DateUtils.pm\
+ lib/GetConfig.pm\
+ lib/Utils.pm\
+ clearadm/lib/Clearexec.pm\
+ clearadm/clearagent.pl\
+ clearadm/clearexec.pl\
+ clearadm/etc/clearexec.conf\
+ clearadm/etc/conf.d/clearadm\
+ clearadm/etc/init.d/clearagent\
+ clearadm/etc/init.d/cleartasks\
+ clearadm/load.vbs\
+ clearadm/log\
+ clearadm/setup.pl\
+ clearadm/var
+TARGETS = clearlib.tar.gz\
+ clearcc.tar.gz\
+ clearcq.tar.gz\
+ clearadm.tar.gz\
+ clearenv.tar.gz\
+ clearagent.tar.gz
+
+all: $(TARGETS)
+
+clean:
+ @rm -f $(TARGETS)
+
+clearlib.tar.gz: $(CLEARLIB)
+ @tar --exclude CVS -zcf $@ $(CLEARLIB)
+
+clearcc.tar.gz: $(CLEARCC)
+ @tar --exclude CVS -zcf $@ $(CLEARCC)
+
+clearcq.tar.gz: $(CLEARCQ)
+ @tar --exclude CVS -zcf $@ $(CLEARCQ)
+
+clearadm.tar.gz: $(CLEARADM)
+ @tar --exclude CVS -zcf $@ $(CLEARADM)
+
+clearenv.tar.gz: $(CLEARENV)
+ @tar --exclude CVS -zcf $@ $(CLEARENV)
+
+clearagent.tar.gz: $(CLEARAGENT)
+ @tar --exclude CVS -zcf $@ $(CLEARAGENT)
--- /dev/null
+.perldb.hist
+.cvsignore
--- /dev/null
+\@main::INC
+EOT
+my $subref = \&dumpvar_epic::dump_array_expr;
+my $savout = CORE::select($DB::OUT);
+my $savbuf = $|;
+$| = 0;
+$subref->($offset, $varexpr);
+$| = $savbuf;
+print "";
+CORE::select($savout);
+};
+
+;{
+do 'dumpvar_epic.pm' unless defined &dumpvar_epic::dump_lexical_vars;
+
+my $offset = 0;
+my $varexpr = <<'EOT';
++{%main::INC}
+EOT
+my $subref = \&dumpvar_epic::dump_hash_expr;
+my $savout = CORE::select($DB::OUT);
+my $savbuf = $|;
+$| = 0;
+$subref->($offset, $varexpr);
+$| = $savbuf;
+print "";
+CORE::select($savout);
+};
+
+;{
+do 'dumpvar_epic.pm' unless defined &dumpvar_epic::dump_lexical_vars;
+
+my $offset = 0;
+my $varexpr = <<'EOT';
++{%main::SIG}
+EOT
+my $subref = \&dumpvar_epic::dump_hash_expr;
+my $savout = CORE::select($DB::OUT);
+my $savbuf = $|;
+$| = 0;
+$subref->($offset, $varexpr);
+$| = $savbuf;
+print "";
+CORE::select($savout);
+};
+
+;{
+do 'dumpvar_epic.pm' unless defined &dumpvar_epic::dump_lexical_vars;
+
+my $offset = 0;
+my $varexpr = <<'EOT';
+$h->{'%violations'}
+EOT
+my $subref = \&dumpvar_epic::dump_hash_expr;
+my $savout = CORE::select($DB::OUT);
+my $savbuf = $|;
+$| = 0;
+$subref->($offset, $varexpr);
+$| = $savbuf;
+print "";
+CORE::select($savout);
+};
+
+;{
+do 'dumpvar_epic.pm' unless defined &dumpvar_epic::dump_lexical_vars;
+
+my $offset = 0;
+my $varexpr = <<'EOT';
+$h->{'@lines'}
+EOT
+my $subref = \&dumpvar_epic::dump_array_expr;
+my $savout = CORE::select($DB::OUT);
+my $savbuf = $|;
+$| = 0;
+$subref->($offset, $varexpr);
+$| = $savbuf;
+print "";
+CORE::select($savout);
+};
+
+c 188
+x \%violations
+x $nbrViolations
+x $ip
+x $violations{$ip}
+x @emails
+x $ip
+x $message
+c 285
+x $email
+x $email
+$email=1
+x $message
+$to="andrew\@defaria.com"
+$to="andrew\@defaria.com"
+c 228
+x \%violations
+c 235
+x $attempts
+x $violations{$ip}
--- /dev/null
+#!/bin/bash
+################################################################################
+#
+# File: $RCSfile: backup,v $
+# Revision: $Revision: 1.7 $
+# Description: This script backs up the system in a consistent way
+# Author: Andrew@DeFaria.com
+# Created: Tue Jul 27 15:00:11 PDT 2004
+# Modified: $Date: 2011/05/26 06:17:20 $
+# Language: Bash
+#
+# (c) Copyright 2000-2005, ClearSCM, Inc., all rights reserved.
+#
+################################################################################
+# Full Backup
+backup=/sbin/dump
+dumppath=/backup
+files2backup=/
+
+if [ -f /etc/dump.excludes ]; then
+ excludes="-E /etc/dump.excludes"
+else
+ excludes=""
+fi
+
+if [ $(id -u) -ne 0 ]; then
+ echo "You must be root to backup"
+ exit 1
+fi
+
+function usage {
+ type="$1"
+
+ echo "Usage: backup <full | incremental>"
+ exit 1
+} # usage
+
+type="$1"
+host=$(hostname)
+
+host=$(hostname)
+
+if [ "$type" = "full" ]; then
+ rm -f $dumppath/$host.$type.backup
+ rm -f $dumppath/$host.$type.backup.log
+ rm -f $dumppath/$host.$type.list
+ level=0
+elif [ "$type" = "incremental" ]; then
+ level=1
+else
+ usage $type
+fi
+
+log=$dumppath/$host.$type.backup.log
+
+$backup -$level\
+ -A $dumppath/$host.$type.list\
+ -f $dumppath/$host.$type.backup\
+ -z\
+ $excludes\
+ -u $files2backup > $log 2>&1
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: bice.pl,v $
+
+Report breakin attempts to this domain
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.3 $
+
+=item Created:
+
+Fri Mar 18 01:14:38 PST 2005
+
+=item Modified:
+
+$Date: 2013/05/30 15:35:27 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage: bice [-u|sage] [-v|erbose] [-d|ebug] [-nou|pdate] [-nom|ail]
+ [-f|ilename <filename> ]
+
+ Where:
+ -u|sage Print this usage
+ -v|erbose: Verbose mode (Default: -verbose)
+ -nou|pdate: Don't update security logfile file (Default: -update)
+ -nom|ail: Don't send emails (Default: -mail)
+ -f|ilename: Open alternate messages file (Default: /var/log/auth.log)
+
+=head1 DESCRIPTION
+
+This script will look at the security logfile for attempted breakins and then
+use whois to report them to the upstream provider.
+
+=cut
+
+use strict;
+use warnings;
+
+use FindBin;
+use Getopt::Long;
+
+use lib "$FindBin::Bin/../lib";
+
+use Display;
+use Mail;
+use Utils;
+
+use Fcntl ':flock'; # import LOCK_* constants
+
+my $security_logfile = '/var/log/auth.log';
+
+# Customize these variables
+my $domain = 'DeFaria.com';
+my $contact = 'Andrew@DeFaria.com';
+my $location = 'San Diego, California, USA';
+my $UTC = 'UTC-8';
+my $mailhost = $domain;
+# End customize these variables
+
+my $verbose;
+my $update = 1;
+my $email = 1;
+my $hostname = `hostname`;
+chomp $hostname;
+
+if ($hostname =~ /(\w*)\./) {
+ $hostname = $1;
+} # if
+
+sub AddToIPTables (@) {
+ my (@ips) = @_;
+
+ # We shouldn't need to weed out duplicate but ya never know
+ my $ipfilename = '/etc/ipblock';
+
+ my $result = open my $ipfile, '<', $ipfilename;
+
+ my (%ips, @oldips);
+
+ if ($result) {
+ @oldips = <$ipfile>;
+
+ close $ipfile if $ipfile;
+
+ chomp @oldips;
+ } # if
+
+ map { $ips{$_} = 1 } @oldips;
+ map { $ips{$_} = 1 } <@ips>;
+
+ open $ipfile, '>', "$ipfilename"
+ or error "Unable to open $ipfilename - $!", 1;
+
+ foreach (sort keys %ips) {
+ print $ipfile "$_\n";
+ } # foreach
+
+ close $ipfile;
+
+ # Recreate the BICE chain
+ `/sbin/iptables -F BICE`;
+ `/sbin/iptables -X BICE`;
+ `/sbin/iptables -N BICE`;
+
+ # Add all new @ips to iptables
+ `/sbin/iptables -A BICE -s $_ -p tcp --destination-port 22 -j DROP` foreach (sort keys %ips);
+
+ return;
+} # AddToIPTables
+
+# Use whois(1) to get the email addresses of the responsible parties for an IP
+# address. Note that a hash is used to eliminate duplicates.
+sub GetEmailAddresses ($) {
+ my ($ip) = @_;
+
+ # List of whois servers to try
+ my @whois_list = (
+ '',
+ 'whois.arin.net',
+ 'whois.nsiregistry.net',
+ 'whois.opensrs.net',
+ 'whois.networksolutions.com',
+ );
+
+ my %email_addresses;
+
+ foreach (@whois_list) {
+ my @lines;
+
+ if ($_ eq "") {
+ @lines = grep { /.*\@.*/ } `whois $ip`;
+ } else {
+ @lines = grep {/.*\@.*/ } `whois -h $_ $ip`;
+ } # if
+
+ foreach (@lines) {
+ my @fields = split /:/, $_;
+
+ $_ = $fields [@fields - 1];
+
+ if (/(\S+\@\S[\.\S]+)/) {
+ $email_addresses{$1} = "";
+ } # if
+ } # foreach
+
+ # Break out of loop if we found email addresses
+ last unless keys %email_addresses;
+ } # foreach
+
+ return keys %email_addresses;
+} # GetEmailAddresses
+
+# Send email to the responsible parties.
+sub SendEmail ($$$$$) {
+ my ($to, $subject, $message, $ip, $violations) = @_;
+
+ if ($email) {
+ verbose "Reporting $ip ($violations violations) to $to";
+ } else {
+ verbose "Would have reported $ip ($violations violations) to $to";
+ return;
+ } # if
+
+ mail (
+ from => "BICE\@$domain",
+ to => $to,
+ cc => $contact,
+ subject => $subject,
+ mode => 'html',
+ data => $message,
+ );
+} # SendEmail
+
+sub processLogfile () {
+ my %violations;
+
+ # Note: Normally you must be root to open up $security_logfile
+ open my $readlog, '<', $security_logfile
+ or error "Unable to open $security_logfile - $!", 1;
+
+ flock $readlog, LOCK_EX
+ or error "Unable to flock $security_logfile", 1;
+
+ my @lines;
+
+ while (<$readlog>) {
+ my $newline = $_;
+
+ if (/^(\S+\s+\S+\s+\S+)\s+.*Invalid user (\w+) from (\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})/) {
+ my %violation = $violations{$3} ? %{$violations{$3}} : %_;
+
+ push @{$violation{$2}}, $1;
+
+ $violations{$3} = \%violation;
+
+ $newline =~ s/Invalid user/INVALID USER/;
+ } elsif (/^(\S+\s+\S+\s+\S+)\s+.*authentication failure.*ruser=(\S+).*rhost=(\S+)/) {
+ my %violation = $violations{$3} ? %{$violations{$3}} : %_;
+
+ push @{$violation{$2}}, $1;
+
+ $violations{$3} = \%violation;
+
+ $newline =~ s/authentication failure/AUTHENTICATION FAILURE/;
+ } elsif (/^(\S+\s+\S+\s+\S+)\s+.*Failed password for (\w+) from (\d{1,3}\.\d{1,3}\.d{1,3}\.d{1,3})/) {
+ my %violation = $violations{$3} ? %{$violations{$3}} : %_;
+
+ push @{$violation{$2}}, $1;
+
+ $violations{$3} = \%violation;
+
+ $newline =~ s/Failed password/FAILED PASSWORD/;
+ } # if
+
+ push @lines, $newline;
+ } # while
+
+ return %violations unless $update;
+
+ flock $readlog, LOCK_UN
+ or error "Unable to unlock $security_logfile", 1;
+
+ close $readlog;
+
+ open my $writelog, '>', $security_logfile
+ or error "Unable to open $security_logfile for writing - $!", 1;
+
+ flock $writelog, LOCK_EX
+ or error "Unable to flock $security_logfile", 1;
+
+ print $writelog $_ foreach @lines;
+
+ flock $writelog, LOCK_UN
+ or error "Unable to unlock $security_logfile", 1;
+
+ close $writelog;
+
+ return %violations;
+} # processLogfile
+
+# Report breakins to the authorities.
+sub ReportBreakins () {
+ my %violations = processLogfile;
+
+ my $nbrViolations = keys %violations;
+
+ if ($nbrViolations == 0) {
+ verbose 'No violations found';
+ } elsif ($nbrViolations == 1) {
+ verbose '1 site attempting to violate our perimeter';
+ } else {
+ verbose "$nbrViolations sites attempting to violate our perimeter";
+ } # if
+
+ foreach (sort keys %violations) {
+ my $ip = $_;
+
+ my $attempts;
+
+ $attempts += @{$violations{$ip}{$_}} foreach (keys %{$violations{$ip}});
+
+ my @emails = GetEmailAddresses $ip;
+
+ unless (@emails) {
+ verbose 'Unable to find any responsible parties for detected breakin '
+ . "attempts from IP $ip ($attempts breakin attempts)";
+ next;
+ } # unless
+
+ my $to = join ',', @emails;
+ my $subject = "Illegal attempts to break into $domain from your domain";
+ my $message = <<"END";
+<p>Somebody from your domain with an IP Address of <b>$ip</b> has been
+attempting to break into my domain, <b>$domain</b>. <u>Breaking into somebody
+else's computer is illegal and criminal prosecution can result!</u> As a
+responsible ISP it is in your best interests to investigate such activity and to
+shutdown any such illegal activity as it is a violation of law and most likely a
+violation of your user level agreement. It is expected that you will investigate
+this and send the result and/or disposition of your investigation back to
+$contact. <font color=red><b>If you fail to do so then criminal prosecution may
+result!</b></font></p>
+
+<p>Please be aware that <b>none</b> of these attempts to breakin have been
+successful - this system is configured such that only trusted users are allowed
+to log in as they must provide authenticated keys in advance. So your attempts
+have been wholly unsuccessful. Still, this does not diminish the illegality nor
+the ability of us to pursue this matter in a court of law.</p>
+
+<p>There were a total of $attempts attempts to break into $domain. The following
+is a report of the breakin attempts from IP Address $ip along with the usernames
+attempted and the time of the attempt:</p>
+
+<p>Note: $domain is located in $location. All times are $UTC:</p>
+
+<ol>
+END
+ # Report users
+ foreach my $user (sort keys %{$violations{$ip}}) {
+ if (@{$violations{$ip}{$user}} == 1) {
+ $message .= "<li>The user <b>$user</b> attempted access on $violations{$ip}{$user}[0]</li>";
+ } else {
+ $message .= "<li>The user <b>$user</b> attemped access on the following date/times:</li>";
+ $message .= "<ol>";
+ $message .= "<li>$_</li>" foreach (@{$violations{$ip}{$user}});
+ $message .= "</ol>";
+ } # if
+ } # foreach
+
+ $message .= '</ol><p>Your prompt attention to this matter is expected '
+ . 'and will be appreciated.</p>';
+ SendEmail $to, $subject, $message, $ip, $attempts;
+ } # foreach
+
+ AddToIPTables keys %violations;
+} # ReportBreakins
+
+## Main
+
+# Get options
+GetOptions (
+ 'verbose', sub { set_verbose },
+ 'debug', sub { set_debug },
+ 'usage', sub { Usage },
+ 'update!', \$update,
+ 'mail!', \$email,
+ 'file=s', \$security_logfile,
+) || Usage;
+
+Usage 'Must specify filename'
+ unless $security_logfile;
+
+ReportBreakins;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<FindBin>
+
+L<Getopt::Long|Getopt::Long>
+
+L<Fcntl>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ Display
+ Mail
+ Utils
+
+=end man
+
+=begin html
+
+<blockquote>
+<<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Mail.pm">Mail</a><br>
+a href="http://clearscm.com/php/cvs_man.php?file=lib/Utils.pm">Utils</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this script
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2010, ClearSCM, Inc. All rights reserved.
+
+=cut
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: $RCSfile: bigfiles.pl,v $
+# Revision: $Revision: 1.3 $
+# Description: Reports large files
+# Author: Andrew@DeFaria.com
+# Created: Mon May 24 09:09:24 PDT 1999
+# Modified: $Date: 2011/04/18 05:15:29 $
+# Language: Perl
+#
+# (c) Copyright 2001, ClearSCM, Inc., all rights reserved
+#
+################################################################################
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/../lib";
+
+use Getopt::Long;
+
+use OSDep;
+use Display;
+
+sub Usage {
+ display "Usage: bigfiles: [ -verbose | -v ] [ -size | -s n ] [ <directory> ]";
+ display "\t\t[ -top n | -t n ] [ -notop | -not ]\n";
+ display "Where:";
+ display " -size | -s n\tShow only files bigger then n Meg (default 1 Meg)";
+ display " -verbose | -v\tTurn on verbose mode (default verbose off)";
+ display " -top | -t n\tPrint out only the top n largest files (default LINES - 1)";
+ display " -notop|not\tPrint out all files (default top LINES - 1)";
+ display " <directory>\tDirectory paths to check";
+ exit 1;
+} # usage
+
+sub Bigfiles {
+ my $size = shift;
+ my @dirs = @_;
+
+ my @files;
+
+ foreach (@dirs) {
+ next if !-d "$_";
+ my $cmd = "find \"$_\" -xdev -type f -size +$size -exec ls -lLGQ {} \\;";
+ my @lines = `$cmd`;
+
+ foreach (@lines) {
+ chomp;
+
+ my %info;
+
+ if (/\S+\s+\d+\s+(\S+)\s+(\d+).*\"\.\/(.*)\"/) {
+ $info {user} = $1;
+ $info {filesize} = $2;
+ $info {filename} = $3;
+ push @files, \%info;
+ } # if
+ } # foreach
+ } # foreach
+
+ return @files;
+} # Bigfiles
+
+my $lines = defined $ENV {LINES} ? $ENV {LINES} :-24;
+my $top = $lines - 2;
+my $bytes_in_meg = 1048576;
+my $block_size = 512;
+my $size_in_meg = 1;
+my %opts;
+
+my $result = GetOptions (
+ \%opts,
+ usage => sub { Usage },
+ verbose => sub { set_verbose },
+ debug => sub { set_debug },
+ 'top=i',
+ 'size=i',
+);
+
+my @dirs = @ARGV ? @ARGV : ".";
+
+my $size = $opts {size} ? $opts {size} * $bytes_in_meg / $block_size : 4096;
+
+# Now do the find
+verbose "Directory:\t$_"
+ foreach (@dirs);
+verbose "Size:\t\t$size_in_meg Meg ($size blocks)";
+verbose "Top:\t\t$top";
+
+my $head = $top ? "cat" : "head -$top";
+
+my @files = Bigfiles $size, @dirs;
+
+foreach (@files) {
+ my %info = %{$_};
+
+ print "${info {filesize}}\t${info {user}}\t${info {filename}}\n";
+} # foreach
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: checkdns,v $
+
+Check DNS by attempting to call gethostbyname of a well known host.
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.6 $
+
+=item Created:
+
+Wed Aug 30 21:03:14 CDT 2006
+
+=item Modified:
+
+$Date: 2011/04/15 15:05:16 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage: checkdns [-u|sage] [-v|erbose] [-d|ebug]
+ [-s|leep <n>] [-l|ogpath <path>]
+
+ Where:
+ -u|sage Print this usage
+ -v|erbose: Verbose mode
+ -d|ebug: Emit debug information
+
+ -s|leep <n>: Set sleep period to <n> minutes (Default: 15 minutes)
+ -l|ogpath <path>: Put the log file in <path> (Default: /var/log)
+
+=head1 DESCRIPTION
+
+This script will look at the security logfile for attempted breakins and then
+use whois to report them to the upstream provider.
+
+=cut
+
+use strict;
+use warnings;
+
+use Getopt::Long;
+
+use FindBin;
+
+use lib "$FindBin::Bin/../lib";
+
+use Logger;
+use Utils;
+use Display;
+
+my $VERSION = '$Revision: 1.6 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+$0 = $FindBin::Script;
+
+my $host = 'google.com';
+my $sleep = 15;
+my $initial_sleep = $sleep;
+my $logpath = '/var/log';
+my $log;
+
+sub CheckDNS {
+ my ($host) = @_;
+
+ $? = 0;
+
+ my @ipaddrs = gethostbyname $host;
+
+ if (!@ipaddrs) {
+ debug "Host: $host (ipaddrs empty)";
+
+ # Cut down sleep time to monitor this outage more closely but do not go
+ # below once a minute.
+ if ($sleep > 1) {
+ $sleep -= $sleep / 2;
+ } else {
+ $sleep = 1;
+ } # if
+
+ return 1;
+ } # if
+
+ # Successful lookup - set $sleep to $initial_sleep
+ $sleep = $initial_sleep;
+
+ return;
+} # CheckDNS
+
+sub Shutdown {
+ my $msg;
+
+ my $errors = $log->errors;
+
+ $log->msg ("$errors errors encountered since starting")
+ if $errors;
+
+ $log->msg ('Caught interrupt - shutting down');
+
+ exit $errors;
+} # Interrupt
+
+# Main
+GetOptions (
+ usage => sub { Usage },
+ verbose => sub { set_verbose },
+ debug => sub { set_debug },
+ 'sleep=i' => \$sleep,
+ 'logpath=s' => \$logpath,
+) or Usage 'Invalid parameter';
+
+$SIG {INT} =
+$SIG {TERM} = \&Shutdown;
+
+# Call sethostent so that gethostbyname is fresh everytime
+sethostent (0);
+
+$log = Logger->new (
+ path => $logpath,
+ timestamped => 'yes',
+ append => 'yes',
+);
+
+$log->msg (
+ "Started $FindBin::Script $VERSION logging to $logpath/$FindBin::Script.log"
+);
+
+$log->msg ("Polling DNS on host $host every $sleep minutes");
+
+EnterDaemonMode
+ unless get_debug;
+
+while () {
+ my $status = CheckDNS $host;
+
+ if ($status) {
+ $log->err ("Unable to resolve IP address for $host");
+ } else {
+ $log->msg ("Successfully resolved $host");
+ } # if
+
+ sleep ($sleep * 60);
+} # while
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<FindBin>
+
+L<Getopt::Long|Getopt::Long>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ Display
+ Logger
+ Utils
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Logger.pm">Logger</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Utils.pm">Utils</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this script
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2004, ClearSCM, Inc. All rights reserved.
+
+=cut
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: $RCSfile: diskspace,v $
+# Revision: $Revision: 1.2 $
+# Description: Check filesystems to see if they are becoming too full
+# Author: Andrew@DeFaria.com
+# Created: Fri Mar 12 10:17:44 PST 2004
+# Modified: $Date: 2010/06/08 15:03:27 $
+# Language: Perl
+#
+# (c) Copyright 2005, ClearSCM, Inc., all rights reserved
+#
+################################################################################
+use strict;
+use warnings;
+use File::Spec;
+
+use FindBin;
+use lib "$FindBin::Bin/../lib";
+
+use Display;
+
+my $threshold = 90;
+
+sub Usage {
+ my $msg = shift;
+
+ display "ERROR: $msg\n" if defined $msg;
+
+ display "diskspace\t[-v] [-d] [-u] [ -t <threshold> ]";
+ display "\t-v\tTurn on verbose mode";
+ display "\t-d\tTurn on debug mode";
+ display "\t-u\tThis usage message";
+ display "\t-t\tThreshold (0-100)";
+
+ exit 1;
+} # Usage
+
+sub CheckLocalFilesystems {
+ my @local_filesystems = `df -lP`;
+
+ @local_filesystems = grep {/^\/dev/} @local_filesystems;
+
+ foreach (@local_filesystems) {
+ my ($fs, $blocks, $used, $available, $used_percent, $mounted_on) = split;
+
+ if ($used_percent =~ /(\d+)%/) {
+ $used_percent = $1;
+ } # if
+
+ $available = sprintf ("%.3f", $available / 1024);
+
+ # Check if over threshold and report
+ if ($used_percent <= $threshold ) {
+ verbose "$mounted_on is $used_percent% full - $available Megs left";
+ } else {
+ warning "$mounted_on is $used_percent% full - $available Megs left";
+ } # if
+ } # foreach
+} # CheckLocalFilesystems
+
+# Get parameters
+while ($ARGV [0]) {
+ if ($ARGV [0] eq "-v") {
+ set_verbose;
+ } elsif ($ARGV [0] eq "-d") {
+ set_debug;
+ } elsif ($ARGV [0] eq "-t") {
+ shift (@ARGV);
+ if (!$ARGV [0]) {
+ Usage "Must specify threshold after -t";
+ } else {
+ $threshold = $ARGV [0];
+ } # if
+ } elsif ($ARGV [0] eq "-u") {
+ Usage;
+ } else {
+ Usage "Unknown argument found: " . $ARGV [0];
+ } # if
+
+ shift (@ARGV);
+} # while
+
+verbose "Theshold: $threshold\%";
+CheckLocalFilesystems;
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: $RCSfile: httpdwho,v $
+# Revision: $Revision: 1.2 $
+# Description: Parse Apache access.log and produce a report on the locations
+# of the visitors to the site
+# Author: Andrew@DeFaria.com
+# Created: Thu Dec 21 21:49:54 CST 2006
+# Modified: $Date: 2010/06/08 15:03:27 $
+# Dependencies: GEOLite
+# Language: Perl
+#
+# This product includes GeoLite data created by MaxMind, available from
+# http://www.maxmind.com
+#
+# (C) Copyright 2006, ClearSCM, Inc., all rights reserved.
+#
+################################################################################
+use strict;
+use warnings;
+
+use FindBin;
+use Getopt::Long;
+
+use lib "$FindBin::Bin/../lib";
+
+use Display;
+use Utils;
+
+use Geo::IP::PurePerl;
+
+sub Usage (;$) {
+ my $msg = shift;
+
+ dipslay $msg if $msg;
+ display "Usage: $FindBin::Script: [ -verbose | -v ] <filename>";
+ display "\nWhere:";
+ display " -verbose | -v\tTurn on verbose mode (Default: verbose off)";
+ display " <filename>\tIs the Apache formated access logfile";
+ exit 1;
+} # usage
+
+sub GetIPs ($) {
+ my $filename = shift;
+
+ my %ipaddrs;
+
+ verbose_nolf "Processing $filename";
+
+ foreach (ReadFile ($filename)) {
+ verbose_nolf ".";
+
+ my @fields = split;
+ my @ipaddrs = gethostbyname $fields [0];
+
+ next if !@ipaddrs; # Skip errors
+
+ my ($a, $b, $c, $d) = unpack "C4", $ipaddrs [4];
+ my $ipaddr = "$a.$b.$c.$d";
+
+ debug "Host: ${fields [0]} IP: $ipaddr";
+
+ if ($ipaddrs {$ipaddr}) {
+ $ipaddrs {$ipaddr}[1]++;
+ } else {
+ my @domain_info;
+ $domain_info [0] = $ipaddrs [0];
+ $domain_info [1] = 1;
+ $ipaddrs {$ipaddr} = \@domain_info;
+ } # if
+ } # foreach
+
+ verbose "\nFinished processing $filename";
+ return %ipaddrs;
+} # GetIPs
+
+my $logfile = "/var/log/httpd/access_log";
+
+my $result = GetOptions (
+ "file=s" => \$logfile,
+ "usage" => sub { Usage },
+ "verbose" => sub { set_verbose },
+ "debug" => sub { set_debug },
+) or Usage "Invalid option specified";
+
+# Instantiate a new Geo::IP object
+my $gi = Geo::IP::PurePerl->new (
+ "/usr/local/share/GeoIP/GeoIPCity.dat",
+ GEOIP_STANDARD
+);
+
+# Turn off buffering
+$| = 1;
+
+error "Unable to open $logfile", 1 if !-f $logfile;
+
+my %ip_records = GetIPs $logfile;
+
+foreach (sort keys %ip_records) {
+ my (
+ $country_code,
+ $country_code3,
+ $country_name,
+ $region,
+ $city,
+ $postal_code,
+ $latitude,
+ $longitude,
+ $dma_code,
+ $area_code)
+ = $gi->get_city_record ($_);
+
+ my @domain_info = @{$ip_records {$_}};
+
+ display_nolf "$_\t";
+ display_nolf $city ? "$city\t" : "*Unknown*\t";
+ display_nolf $postal_code ? "$postal_code\t" : "*Unknown*\t";
+ display_nolf $country_name ? "$country_name\t" : "*Unknown*\t";
+ display $domain_info [0] . " (" . $domain_info [1] . ")";
+# print $country_code . "\n";
+# print $country_code3 . "\n";
+# print $country_name . "\n";
+# print $region . "\n";
+# print $city . "\n";
+# print $postal_code . "\n";
+# print $latitude . "\n";
+# print $longitude . "\n";
+# print $dma_code . "\n";
+# print $area_code . "\n";
+} # foreach
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: $RCSfile: mkplaylist,v $
+# Revision: $Revision: 1.5 $
+# Description: Script to generate a random playlist of x nbr files
+# Author: Andrew@DeFaria.com
+# Created: Wed Sep 13 09:56:55 CDT 2006
+# Modified: $Date: 2011/01/09 00:54:42 $
+# Language: Perl
+#
+# (c) Copyright 2006, ClearSCM, Inc., all rights reserved.
+#
+################################################################################
+use strict;
+use warnings;
+
+use MP3::Info;
+
+use FindBin;
+use lib "$FindBin::Bin/../lib";
+
+use Getopt::Long;
+use Display;
+use OSDep;
+use Utils;
+
+my $version = "1.0";
+my $default_music_root = "/web/Music";
+
+my %opts;
+my @mp3files;
+
+sub Usage {
+ my $msg = shift;
+
+ if (defined $msg) {
+ dipslay $msg;
+ } # if
+
+ display "Usage: $FindBin::Script: [ -verbose | -v ] [ -n <limit> ]";
+ display "\t\t [ -f <filename> ] [ -m <music_root> ]";
+ display "\nWhere:\n";
+ display " -n <limit>\t\tLimit playlist to <n> entries (Default: 100 entires)";
+ display " -verbose\t\tTurn on verbose mode (Default: verbose off)";
+ display " -f <filename>\t\tWrite playlist to <filename> (Default: playlist.wpl)";
+ display " -m <music_root>\tStart searching at <music_root> (Default: $default_music_root)";
+ exit 1;
+} # usage
+
+sub GetMusic {
+ my $music_dir = shift;
+
+ opendir MUSIC, "$music_dir"
+ or error "Unable to open music directory $music_dir", 1;
+
+ my @entries = grep {!/^\./} readdir MUSIC;
+
+ my $mp3info;
+
+ closedir MUSIC;
+
+ foreach (@entries) {
+ my $entity = "$music_dir/$_";
+ if (-d "$entity") {
+ debug "Subdirectory found - recursing to $entity...";
+ GetMusic ($entity);
+ } else {
+ if (/\.mp3$/) {
+ debug "\t$_";
+ $mp3info = MP3::Info->new ($entity);
+ verbose_nolf ".";
+ # WPL files don't like &.
+ if (!defined $mp3info->{FILE}) {
+ $mp3info->{FILE} = "Unknown";
+ } else {
+ $mp3info->{FILE} =~ s/&/&/g;
+ # When we run on Linux is /web but from XP it's //Jupiter
+ $mp3info->{FILE} =~ s/\/web/\/\/Jupiter/;
+ } # if
+
+ push @mp3files, $mp3info;
+ } else {
+ debug "-\t$_ skipped";
+ } # if
+ } # if
+ } # foreach
+} # GetMusic
+
+sub RandomizePlaylist {
+ my @mp3files = @_;
+
+ my @return_titles;
+
+ my @genres_to_skip = (
+ "Audio Book",
+ "Educational",
+ "Podcast",
+ "Talk Radio",
+ );
+
+ verbose_nolf "Randomizing playlist (${opts {n}})...";
+
+ # if we are asking for more than we have then just return everything
+ if ($opts {n} > $#mp3files) {
+ $opts {n} = $#mp3files;
+ return @mp3files;
+ } # if
+
+ # Fill @return_titles with randomly selected songs.
+ for (my $i = 0; $i < ${opts{n}};) {
+ my $random = int (rand ($#mp3files));
+
+ # These are random songs - not random speach. Certain genres are
+ # always skipped.
+ next unless defined $mp3files[$random]->{GENRE};
+ next if InArray ($mp3files [$random]->{GENRE}, @genres_to_skip);
+
+ # Crude beginnings to a more sophisticated selection mechanism. If
+ # the t option was given then only consider songs that are in the
+ # Genre specified by t. Note this currently loops forever if more
+ # songs are requested than we have.
+ if (defined $opts {t}) {
+ if ($opts {t} eq $mp3files [$random]->{GENRE}) {
+ # Eliminate dups. No sense in giving back the same song more
+ # than once.
+ if (!InArray $mp3files [$random], @return_titles) {
+ push @return_titles, $mp3files [$random];
+ $i++;
+ } else {
+ debug "Eliminating dup";
+ } # if
+ } # if
+ } else {
+ # Eliminate dups. No sense in giving back the same song more
+ # than once.
+ if (!InArray $mp3files [$random], @return_titles) {
+ push @return_titles, $mp3files [$random];
+ $i++;
+ } else {
+ debug "Eliminating dup";
+ } # if
+ } # if
+ } # for
+
+ verbose " done";
+
+ return @return_titles;
+} # RandomizePlaylist
+
+sub WritePlaylistXML {
+ my @playlist = @_;
+
+ verbose "Writing playlist ${opts {f}}";
+ open PLAYLIST, ">${opts {f}}"
+ or error "Unable to open playlist file ${opts {f}}", 1;
+
+ # Write heading
+ print PLAYLIST <<END;
+<?wpl version="1.0"?>
+<smil>
+ <head>
+ <meta name="Generator" content="Microsoft Windows Media Player -- 10.0.0.3990"/>
+ <author>Andrew\@DeFaria.com Copyright (c) 2006 ($FindBin::Script V$version)</author>
+ <title>Random Playlist of ${opts {n}} songs</title>
+ </head>
+<body>
+<seq>
+END
+
+ my $total_size = 0;
+
+ # Write the songs...
+ foreach (@playlist) {
+ print PLAYLIST " <media src=\"$_->{FILE}\"/>\n";
+ $total_size += $_->{SIZE}
+ } # foreach
+
+ # Write the footing
+ print PLAYLIST <<END;
+</seq>
+</body>
+</smil>
+END
+
+ close PLAYLIST;
+ verbose "${opts {n}} entries writen to ${opts {f}} totaling " .
+ int ($total_size / (1024 * 1024)) . " Meg";
+} # WritePlaylistXML
+
+# Turn off buffering
+$| = 1;
+
+# Set the defaults
+$opts {n} = 100;
+$opts {f} = "random_playlist.wpl";
+$opts {m} = $default_music_root;
+
+my $result = GetOptions (
+ \%opts,
+ "usage" => sub { Usage },
+ "verbose" => sub { set_verbose },
+ "debug" => sub { set_debug },
+ "n=i",
+ "f=s",
+ "t=s",
+ "m=s",
+) || Usage;
+
+verbose "Gathering information about music in ${opts {m}}...";
+GetMusic ($opts {m});
+verbose "\n" . $#mp3files . " files found";
+
+WritePlaylistXML (RandomizePlaylist (@mp3files));
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: nag.pl,v $
+
+Nag: A progressively more agressive reminder program.
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision:
+
+$Revision: 1.6 $
+
+=item Created:
+
+Tue Jul 27 15:00:11 PDT 2004
+
+=item Modified:
+
+$Date: 2013/06/13 14:36:03 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage: nag.pl [-u|sage] [-ve|rbose] [-d|ebug] [-nos|ign] [-noe|xec]
+ [-not|ag]
+
+ Where:
+
+ -u|sage: Displays this usage
+ -ve|rbose: Be verbose
+ -d|ebug: Output debug messages
+
+ -noe|xec: No execute mode - just echo out what would have
+ been done (Default: exec)
+ -not|ag: Tag message with a signature detailing how many
+ times we've sent this email and when was the last time we
+ sent it (Default: Don't tag)
+ -nos|ign: Include random signature from ~/.signatures (Default: Don't
+ sign)
+ -f|ile <file> Use <file> as naglist (Default: ~/.nag/list)
+
+=head1 DESCRIPTION
+
+This script read a file indicating who to remind. The format for this file is:
+
+ <email>|<subject>|<when>|<msgfile>|<sent>|<date>
+
+nag.pl will change a message that was set to send on a particular day of the
+week to daily after 3 messages were sent. So if you set the message to be send
+on say Mon it will be sent to 3 weeks and then flip to be sent daily.
+
+=head1 The following things should be done to improve this system:
+
+=over
+
+=item *
+
+Move naglist and message files to a database
+
+=item *
+
+Change MAPS to recognize when a message is returned from a nag message. Perhaps
+tag it with X-Nag: <nag id> (will this come back when the user replies?). MAPS
+would then white list the sender and deliver the email as well as put the nag in
+a pending state.
+
+=cut
+
+use strict;
+use warnings;
+
+use FindBin;
+use Getopt::Long;
+
+use lib "$FindBin::Bin/../lib";
+
+use DateUtils;
+use Display;
+use Mail;
+use Utils;
+
+my $VERSION = '1.0';
+
+my $exec = 1;
+my ($tag, $sign);
+
+my $nagfile = "$ENV{HOME}/.nag/list";
+
+sub dow () {
+ my @days = ('Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat');
+
+ return $days[(localtime (time)) [6]];
+} # dow
+
+sub sign () {
+ my $sigfile = "$ENV{HOME}/.signatures";
+
+ return unless -r $sigfile;
+
+ my $signature = "-- <br>";
+
+ open my $sigs, '<', $sigfile
+ or error "Unable to open signature file $sigfile - $!", 1;
+
+ my @sigs = <$sigs>;
+ chomp @sigs;
+
+ close $sigs;
+
+ $signature .= '<font color="#bbbbbb">';
+ $signature .= splice (@sigs, int (rand (@sigs)), 1);
+ $signature .= '</font>';
+
+ return $signature;
+} # sign
+
+sub tag ($$) {
+ my ($sent, $date) = @_;
+
+ return ''
+ unless $sent;
+
+ my $tagStr = '<hr><p style="text-align: center;">';
+ $tagStr .= "This message has been sent to you $sent time";
+
+ $tagStr .= 's'
+ if $sent > 1;
+
+ $tagStr .= " before<br>";
+ $tagStr .= "The last time this message was sent to you was $date<br>";
+ $tagStr .= "$FindBin::Script $VERSION<br></p>";
+
+ return $tagStr;
+} # tag
+
+## Main
+GetOptions (
+ usage => sub { Usage },
+ verbose => sub { set_verbose },
+ debug => sub { set_debug },
+ 'exec!' => \$exec,
+ 'tag!', => \$tag,
+ 'sign!', => \$sign,
+ 'file', => \$nagfile,
+) or Usage 'Invalid parameter';
+
+my $nagfilenew = "$nagfile.$$";
+
+open my $nagsIn, '<', $nagfile
+ or error "Unable to open $nagfile for read access - $!", 1;
+
+open my $nagsOut, '>', $nagfilenew
+ or error "Unable to open new nagfile $nagfilenew for write access - $!", 1;
+
+while (<$nagsIn>) {
+ if (/^#/ or /^$/) {
+ print $nagsOut $_;
+ next;
+ } # if
+
+ chomp;
+
+ my ($email, $subject, $when, $msgfile, $sent, $date) = split /\|/;
+
+ $sent ||= 0;
+
+ my $dow = dow;
+
+ if ($when =~ /$dow/i or $when =~ /daily/i) {
+ verbose "Nagging $email with $msgfile...";
+
+ my $footing = '';
+
+ $footing = tag $sent, $date
+ if $tag;
+
+ $footing .= sign
+ if $sign;
+
+ my $msg;
+
+ my $msgfilename = $msgfile;
+ $msgfilename =~ s/~/$ENV{HOME}/;
+
+ open $msg, '<', $msgfilename
+ or error "Unable to open message file $msgfile - $!", 1;
+
+ mail (
+ to => $email,
+ subject => $subject,
+ mode => 'html',
+ data => $msg,
+ footing => $footing,
+ );
+
+ close $msg
+ or error "Unable to close message file $msg - $!", 1;
+
+ $sent++;
+ $date = YMDHM;
+ $when = "Daily"
+ if $sent > 3;
+
+ print $nagsOut "$email|$subject|$when|$msgfile|$sent|$date\n";
+ } else {
+ print $nagsOut "$_\n";
+ } # if
+} # while
+
+close $nagsIn
+ or error "Unable to close $nagfile - $!", 1;
+
+close $nagsOut
+ or error "Unable to close $nagfilenew - $!", 1;
+
+rename $nagfilenew, $nagfile
+ or error "Unable to rename $nagfilenew to $nagfile", 1;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<FindBin>
+
+L<Getopt::Long|Getopt::Long>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ DateUtils
+ Display
+ Mail
+ Utils
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/DateUtils.pm">DateUtils</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Mail.pm">Mail</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Utils.pm">Utils</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this script
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2004, ClearSCM, Inc. All rights reserved.
+
+=cut
\ No newline at end of file
--- /dev/null
+#!/usr/local/bin/perl
+use strict;
+use warnings;
+
+=pod
+
+=head1 NAME $RCSfile: raid,v $
+
+RAiD: Real Aid in Debugging
+
+This script will dynamically load C functions described in a .h file
+and provide a command line interface to calling those functions.
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.1 $
+
+=item Created:
+
+Fri Apr 29 11:58:36 PDT 2011
+
+=item Modified:
+
+$Date: 2012/04/13 18:14:02 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage raid: [-u|sage] [-verb|ose] [-deb|ug] [-vers|ion] [-rc <dir>]
+ [-lo|ad <.h file>] [-li|b <.a file>] [-h|istfile <file>]
+ [-t|imeout <n>]
+
+ Where:
+ -u|sage: Displays usage
+
+ -verb|ose: Be verbose
+ -deb|ug: Output debug messages
+ -vers|ion: Display raid's version and exit
+
+ -rc <file>: Directory to find "run commands"
+ -lo|ad <module>: A module to load
+ -li|b <library>: A library to load
+ -h|istfile <file>: Use <file> as history file.
+ -t|imeout <n>: Set the timeout to n seconds (Default: 5 seconds)
+
+=head1 DESCRIPTION
+
+This script loads functions defined in a C module so that Perl can
+call them dirctly. A C module is defined to be a set of files, a .h
+file and a .a (or .so) file. The .h file must have specific comments
+in it to identify things properly for raid. These are:
+
+=over
+
+=item prototype
+
+A prototype line that describes the C function to call
+
+=item user input
+
+A user input string which, when matched, tells raid to call the
+corresponding C function.
+
+=item help (optional)
+
+A short help string that describes the function.
+
+=item description (optional)
+
+A longer description string that can span multiple lines.
+
+=item category:
+
+A category - either 0 or 1 - defining the category of call. Normally
+this is 1 for type 1 calls. Type 1 calls communicate with the backend
+through debugsh using TIPC and have their output paged. Type 0 calls
+do not use debugsh and are pure C functions. Any output from type 0
+calls are written directly to STDOUT and are not paged.
+
+=back
+
+Other comments can appear that we will just skip.
+
+The format of comments must be close to:
+
+ int add (int a, int b);
+ /**********************************************************
+ prototype: int add (int a, int b)
+ user input: myadd
+ category: 0
+ help: Add two numbers together
+ description: Because Perl's add is not good enough
+ **********************************************************/
+ ...
+ int subtract (int a, int b)
+ /**********************************************************
+ prototype: int subtract (int a, int b)
+ user input: mysub
+ category: 0
+ help: Subtract b from a
+ description: Because Perl's subtract is not good enough
+ **********************************************************/
+ ...
+ void printit (char *s, int i, double f)
+ /**********************************************************
+ prototype: void printit (char *s, int i, double f)
+ user input: printer
+ category: 0
+ help: Print some different datatypes
+ description: A simple routine to print out some different
+ datatypes. Note the void return.
+
+ Turns out void returns are OK but void parms... not so good
+ **********************************************************/
+ ...
+ void backendCall (char *s, int i, double f)
+ /**********************************************************
+ prototype: void backendCall (int i)
+ user input: call back end
+ category: 1
+ help: This calls the back end passing it an int
+ **********************************************************/
+
+=head1 Autoloading
+
+Raid preloads cmds by parsing all .h files in the rc directory. From
+there it learns of all potential commands that can be loaded. A .h
+filename is called the "module name". If a call is made to a function
+raid checks to see if the module has been loaded. If not it loads the
+module using rc/<module>.h and lib/lib<module>.[a|so]. A module is only
+loaded once. See modules command to see what modules have been loaded.
+
+=head1 TYPEMAPS
+
+Inline uses the default Perl typemap file for its default types. This
+file is called /usr/local/lib/perl5/5.6.1/ExtUtils/typemap, or
+something similar, depending on your Perl installation. It has
+definitions for over 40 types, which are automatically used by
+Inline. (You should probably browse this file at least once, just to
+get an idea of the possibilities.)
+
+Inline parses your code for these types and generates the XS code to
+map them. The most commonly used types are:
+
+=over
+
+=item int
+
+=item long
+
+=item double
+
+=item char*
+
+=item void
+
+=item SV*
+
+=back
+
+If you need to deal with a type that is not in the defaults, just use
+the generic SV* type in the function definition. Then inside your
+code, do the mapping yourself. Alternatively, you can create your own
+typemap files and specify them using the TYPEMAPS configuration
+option.
+
+Note that the presence of a file named typemap along side your .h and
+.a file should work.
+
+TYPEMAPS specifies a typemap file that defines non-standard C types
+and how they relate to Perl types.
+
+=head1 COMMAND LINE
+
+Raid implements a command line with full ReadLine support. It
+maintains a history stack of your commands for convenient recall as
+well as audit purposes. Try using the arrow keys or C-p, C-n, C-r
+Emacs bindings. History is saved between sessions in ~/.raid_hist.
+
+There is a small help facility. Type help to get a listing of raid
+commands as well as the currently loaded C functions. Also, "help <C
+function name>" will display the detailed help provided in the .h file
+(if any).
+
+=head1 One liners
+
+You can also call raid and give is a parameter on the command line
+which would be a command to execute. This command may need to be
+quoted if any spaces or other special characters occur in the command.
+
+=head1 Exit status
+
+Raid sets $? equal to the return of the last function called. If the
+last function called returns a string then raid will set $? equal to 1
+if the string has anything in it or 0 if it is empty or undefined.
+
+=head1 Colors
+
+For those of your who are color averse, simply export
+ANSI_COLORS_DISABLED to some value and all coloring will be turned
+off. Or use the color off|on command.
+
+=head1 More information
+
+For more information see the internal wiki page:
+
+=over
+
+=item .
+
+L<http://adp.ca.tellabs.com/twiki/bin/view/9200/RaidDebugShell>
+
+=item .
+
+L<http://adp.ca.tellabs.com/twiki/bin/view/9200/VersionHistory>
+
+=back
+
+=cut
+
+use Config;
+use Getopt::Long;
+use FindBin;
+use File::Spec;
+use File::Basename;
+use IO::Handle;
+
+use Term::ANSIColor qw (color);
+
+# Add our lib directory as well as the appropraite lib areas below "lib" that
+# contain things like our local copy of Term::ReadLine::Gnu and Inline::C.
+use lib "$FindBin::Bin/lib",
+ "$FindBin::Bin/lib/perl5/site_perl",
+ "$FindBin::Bin/lib/lib64/",
+ "$FindBin::Bin/lib/lib64/perl5/site_perl";
+
+use CmdLine;
+use GetConfig;
+use Display;
+use Utils;
+
+use constant DBGSH_APPID => 300;
+
+my $VERSION = '$Revision: 1.1 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+my (%opts, %funcs, %allcmds, %modules, $debugshVer);
+
+%opts = GetConfig "$FindBin::Bin/etc/$FindBin::Script.conf";
+
+my $debugshPid;
+my $name = 'RAiD';
+
+error "$name is not supported on 64 bit versions of Perl", 1
+ if $Config{archname} =~ /64/;
+
+my %raidCmds = (
+ appiddisplay => {
+ help => 'appiddisplay',
+ description => 'Displays App ID information',
+ },
+
+ appidclear => {
+ help => 'appidclear <index>',
+ description => 'Clears the specified App ID index',
+ },
+
+ cmds => {
+ help => 'cmds [<str>]',
+ description => 'Lists currently loaded commands (matching <str>).',
+ },
+
+ debug => {
+ help => 'debug [<on|off>]',
+ description => 'Turn on|off debuging of raid and debugsh. With no options displays
+status of debug.',
+ },
+
+ exit => {
+ help => 'exit',
+ description => "Exits $name.",
+ },
+
+ modules => {
+ help => 'modules',
+ description => 'Displays all available modules',
+ },
+
+ perl => {
+ help => 'perl <expression>',
+ description => 'Evaluate a Perl expression. Must be on one line.',
+ },
+
+ quit => {
+ help => 'quit',
+ description => "Quits $name.",
+ },
+
+ restart => {
+ help => 'restart',
+ description => "Reinitializes $name",
+ },
+
+ timeout => {
+ help => 'timeout [<n>]',
+ description => 'Set timeout to <n> seconds. If n = 0 then timeout is disabled. Without <n> just show current timeout value.',
+ },
+
+ version => {
+ help => 'version',
+ description => 'Displays version information.',
+ },
+);
+
+use Inline;
+
+my $PROMPT;
+
+# Seed PATH and LD_LIBRARY_PATH (Hack)
+$ENV{PATH} = "/usr/wichorus/sysroot/usr/bin:/usr/wichorus/sysroot/usr/libexec/gcc/i386-redhat-linux/4.1.2:$ENV{PATH}";
+$ENV{LD_LIBRARY_PATH} = "/usr/wichorus/sysroot/usr/lib";
+
+my ($cmdline, $attribs, $line, $result, $dsh);
+
+sub terminateDebugSh () {
+ if ($debugshPid) {
+ kill HUP => $debugshPid;
+
+ waitpid $debugshPid, 0;
+
+ my $result = DbgShRaidUnRegister ();
+
+ warning "DbgShRaidRegister returned $result"
+ if $result;
+
+ # Close old debugsh if we are reinitializing
+ close $dsh if $dsh;
+
+ undef $dsh;
+ } # if
+
+ return;
+} # terminateDebugSh
+
+sub set_prompt (;$$) {
+ my ($cmd, $nbr) = @_;
+
+ my $ignstart = $CmdLine::cmdline->{ignstart};
+ my $ignstop = $CmdLine::cmdline->{ignstop};
+
+ my $prompt;
+
+ if ($opts{color}) {
+ return $ignstart . color ('cyan') . $ignstop . $name
+ . $ignstart . color ('reset') . $ignstop . ' <'
+ . $ignstart . color ('yellow') . $ignstop . '\#'
+ . $ignstart . color ('reset') . $ignstop . '> ';
+ } else {
+ return "$name <#>";
+ } # if
+} # set_prompt
+
+sub moduleName ($) {
+ my ($file) = @_;
+
+ my ($module, $path, $suffix) = fileparse ($file, ('\.a$', '\.so$', '\.h$'));
+
+ $module =~ s/lib//;
+
+ return $module;
+} # moduleName
+
+sub parseh ($) {
+ my ($h) = @_;
+
+ my %funcs;
+
+ unless (-f $h) {
+ error "Unable to open file $h - $!";
+ return;
+ } # unless
+
+ open my $file, '<', $h
+ or error "Unable to open $h", 1;
+
+ my (
+ $indefinition,
+ $userinput,
+ $funcname,
+ $help,
+ $description,
+ $module,
+ $prototype,
+ $parms,
+ $returntype,
+ $type
+ );
+
+ while (<$file>) {
+ chomp; chop if /\r$/;
+
+ if (/^\/\*{5,}/) {
+ $indefinition = 1;
+ $type = 0;
+ } elsif (/^\*{5,}/) {
+ error 'Missing user input keyword', 1
+ unless $userinput;
+
+ # We need to loop through and make sure that this new user input string
+ # does not previously appear, even if abbreviated. So we can't have say
+ # a new command - "my command" - when we already had a command such as
+ # "my command is nice".
+ foreach (keys %funcs) {
+ error "Ambiguous command \"$userinput\" & \"$_\" found in $h", 1
+ if /^$userinput /;
+ } # foreach
+
+ # Now test for the other way where we already have "my command" in %funcs
+ # and we are trying to add "my command is nice".
+ my $str;
+
+ foreach my $word (split /\s+/, $userinput) {
+ if ($str) {
+ $str .= " $word";
+ } else {
+ $str .= $word;
+ } # if
+
+ # See if this exactly matches any existing key
+ error "Ambiguous command \"$userinput\" & \"$_\" found in $h", 1
+ if $funcs{$str};
+ } # foreach
+
+ $funcs{$userinput}{funcname} = $funcname; undef $funcname;
+ $funcs{$userinput}{help} = $help; undef $help;
+ $funcs{$userinput}{description} = $description; undef $description;
+ $funcs{$userinput}{module} = $module; undef $module;
+ $funcs{$userinput}{prototype} = $prototype; undef $prototype;
+ $funcs{$userinput}{parms} = $parms; undef $parms;
+ $funcs{$userinput}{returntype} = $returntype; undef $returntype;
+ $funcs{$userinput}{type} = $type; undef $type;
+
+ undef $userinput;
+ } elsif ($indefinition and $_ =~ /^\s*user input:\s*(.+)/i) {
+ $userinput = $1; $userinput =~ s/\s*$//;
+ } elsif ($indefinition and $_ =~ /^\s*prototype:\s*(.+);*/i) {
+ $prototype = $1; $prototype =~ s/\s*$//;
+
+ while ($prototype !~ /\);*\s*$/) {
+ my $line = <$file>;
+
+ if ($line) {
+ chomp; chop if /\r$/;
+
+ # Trim
+ $line =~ s/^\s+//;
+ $line =~ s/\s+$//;
+
+ $prototype .= $line;
+ } else {
+ error "Unterminated function prototype found in $h", 1;
+ } # if
+ } # while
+
+ my $str = $prototype;
+
+ # Remove annoying spaces around delimiters only
+ $str =~ s/\s*(\*|\(|\)|\,)\s*/$1/g;
+
+ my @parts = split /(\s+|\(|\)|\*)/, $str;
+
+ # Handle the case where prototype lacks a return type (technically
+ # invalid but we're such nice guys...). Note we simply assume they meant
+ # "void" for a return type.
+ if ($parts[1] eq '(') {
+ $funcname = $parts[0];
+ $returntype = 'void';
+ $parms = join '', @parts[1..$#parts];
+ } elsif ($parts[1] eq '*') {
+ $funcname = $parts[2];
+ $returntype = "$parts[0]*";
+ $parms = join '', @parts[3..$#parts];
+ } else {
+ $funcname = $parts[2];
+ $returntype = $parts[0];
+ $parms = join '', @parts[3..$#parts];
+ } # if
+
+ $module = moduleName $h;
+ } elsif ($indefinition and $_ =~ /^\s*help:\s*(.*)/i) {
+ $help = $1; $help =~ s/\s*$//;
+ } elsif ($indefinition and $_ =~ /^\s*description:\s*(.*)/i) {
+ my $desc = $1; $desc =~ s/\s*$//;
+
+ $desc =~ s/^\s+//;
+
+ $description = $desc unless $desc eq '';
+ $indefinition = 2;
+ } elsif ($indefinition and $_ =~ /^\s*category:\s*(\d+)/i) {
+ $type = $1;
+ } elsif ($indefinition and $indefinition == 2) {
+ if (/\*{5,}/) {
+ $indefinition = 0;
+ next;
+ } else {
+ s/^\s+//;
+
+ if ($description) {
+ $description .= "\n$_";
+ } else {
+ $description = $_;
+ } # if
+ } # if
+ } # if
+ } # while
+
+ close $file;
+
+ return %funcs;
+} # parseh
+
+sub loadModules ($) {
+ my ($rcdir) = @_;
+
+ # Load all known commands by combing through $FindBin::Bin/rc/*.h
+ opendir my $rc, $rcdir
+ or error "Unable to opendir $rcdir", 1;
+
+ my %moduleFuncs;
+ my @modules = grep { !/^\./ } readdir $rc;
+ @modules = grep { /.+\.h$/ } @modules;
+
+ closedir $rc;
+
+ foreach (@modules) {
+ my $moduleFile = "$rcdir/$_";
+ my $module = moduleName $moduleFile;
+ my %funcs = parseh $moduleFile;
+
+ foreach (keys %funcs) {
+ error "Duplicate definition $_ found in $moduleFile", 1
+ if defined $moduleFuncs{$_};
+
+ $moduleFuncs{$_} = $funcs{$_};
+ } # foreach
+
+ $modules{$module} = {
+ moduleFile => $moduleFile,
+ loaded => 0,
+ };
+ } # foreach
+
+ return %moduleFuncs;
+} # loadModules
+
+sub modules () {
+ my ($moduleName, $moduleStatus, $moduleFile);
+
+ format STDOUT =
+@<<<<<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<
+$moduleName,$moduleStatus
+.
+ foreach $moduleName (sort keys %modules) {
+ next if $moduleName eq 'DbgSh';
+
+ $moduleStatus = ($modules{$moduleName}{loaded}) ? 'loaded' : 'not loaded';
+
+ write;
+ } # foreach
+
+ return;
+} # modules
+
+sub load ($;$) {
+ my ($file, $lib) = @_;
+
+ my ($module, $path, $suffix) = fileparse ($file, ('\.a$', '\.so$', '\.h$'));
+
+ $module =~ s/lib//;
+ $path =~ s/^inc\///;
+
+ display_nolf color ('dark') . "Loading $module..." . color ('reset');
+
+ my $hfile;
+
+ if (-f "$path$module.h") {
+ $hfile = "$path$module.h";
+ } elsif (-f "${path}inc/$module.h") {
+ $hfile = "${path}inc/$module.h";
+ } # if
+
+ unless ($hfile) {
+ display '';
+ error "Unable to load $module - .h file missing";
+ return;
+ } # unless
+
+ my $libfile;
+
+ if ($lib and -f $lib) {
+ $libfile = $lib;
+ } elsif (-f "${path}lib$module.a") {
+ $libfile = "${path}lib$module.a";
+ } elsif (-f "${path}lib$module.so") {
+ $libfile = "${path}lib$module.so";
+ } elsif (-f "${path}lib/lib$module.a") {
+ $libfile = "${path}lib/lib$module.a";
+ } elsif (-f "${path}lib/lib$module.so") {
+ $libfile = "${path}lib/lib$module.so";
+ } elsif (-f "${path}../lib/lib$module.a") {
+ $libfile = "${path}../lib/lib$module.a";
+ } elsif (-f "${path}../lib/lib$module.so") {
+ $libfile = "${path}../lib/lib$module.so";
+ } # if
+
+ unless ($libfile) {
+ display '';
+ error "Unable to load $module - .a or .so file missing";
+ return;
+ } # unable
+
+ # Need absolute pathname for -L
+ my $libpath;
+
+ (undef, $libpath, $libfile) =
+ File::Spec->splitpath (File::Spec->rel2abs ($libfile));
+
+ # Strip trailing "/", if any
+ $libpath =~ s/\/$//;
+
+ # Compose $libs
+ my $devWinfraLibPath = "$FindBin::Bin/../../../../9200_packetcore/"
+ . "packetcore/infra/lib/src";
+ my $prodWinfraLibPath = '/usr/wichorus/lib';
+ my $devDbgShLibPath = "$FindBin::Bin/lib";
+ my $libs = "-L$libpath -L$libpath/lib -L$devWinfraLibPath -L$devDbgShLibPath "
+ . "-L$prodWinfraLibPath -l$module -lDbgSh -lwinfra -lrt";
+ $libs .= " $opts{additionallibs}" if $opts{additionallibs};
+
+ verbose "Binding C functions defined in $hfile";
+ debug "Loading module $module";
+ debug "libs = $libs";
+
+ my ($status, @output) = Execute 'uname -r';
+
+ if ($output[0] =~ /WR3.0.2ax_cgl/) {
+ my $sysroot = '/usr/wichorus/sysroot';
+
+ Inline->bind (
+ C => $hfile,
+ CC => "$sysroot/usr/bin/gcc",
+ LD => "$sysroot/usr/bin/ld",
+ CCFLAGS => "-I$sysroot/usr/include -I$sysroot/usr/lib/gcc/i386-redhat-linux/4.1.2/include",
+ LDDLFLAGS => "-fPIC -shared -O2 -L$sysroot/usr/lib -L/usr/local/lib",
+ LIBS => $libs,
+ ENABLE => 'AUTOWRAP',
+ FORCE_BUILD => $opts{build},
+ BUILD_NOISY => $opts{noisy},
+ CLEAN_AFTER_BUILD => $opts{clean},
+ PRINT_INFO => $opts{info},
+ );
+ } else {
+ Inline->bind (
+ C => $hfile,
+ LIBS => $libs,
+ ENABLE => 'AUTOWRAP',
+ FORCE_BUILD => $opts{build},
+ BUILD_NOISY => $opts{noisy},
+ CLEAN_AFTER_BUILD => $opts{clean},
+ PRINT_INFO => $opts{info},
+ );
+ } # if
+
+ # Now the module's loaded
+ $modules{$module}{loaded} = 1;
+ $modules{$module}{moduleFile} = $hfile;
+
+ $CmdLine::cmdline->set_prompt (set_prompt);
+
+ # Rebuild %allcmds
+ %allcmds = %raidCmds;
+
+ $allcmds{$_} = $funcs{$_} foreach (keys %funcs);
+
+ # Set cmds
+ $CmdLine::cmdline->set_cmds (%allcmds);
+
+ display color ('dark') . 'done' . color ('reset');
+
+ return 1;
+} # load
+
+sub getOutput () {
+ my ($status, @output) = (0, ());
+
+ debug "ENTER: getOutput";
+
+ eval {
+ while (<$dsh>) {
+ debug "read: $_";
+ if (/\s*DBGSH\s*\[$debugshPid\]:\s*(\d+)$/) {
+ debug "Found DBGSH line - status = $1";
+ $status = $1;
+ last;
+ } # if
+
+ # Trim output of both \n and \r;
+ chomp; chop if /\r$/;
+
+ debug "Pushing '$_' on output";
+ push @output, $_
+ } # while
+ };
+
+ if ($@ =~ /Operation aborted/) {
+ debug "Operation aborted - cleaning pipe";
+
+ # Need to remove debris from the pipe
+ while (<$dsh>) {
+ debug "Found debris: $_";
+
+ if (/\s*DBGSH\s*\[$debugshPid\]:\s*(\d+)$/) {
+ debug "Found DBSH line - status = $1";
+ $status = $1;
+ last;
+ } # if
+ } # while
+
+ debug "Returning error $@";
+ return (undef, ($@));
+ } else {
+ debug "Returning output (Status: $status)";
+ return ($status, @output);
+ } # if
+} # getOutput
+
+sub debugshInit () {
+ my @debugsh = ($opts{debugsh});
+
+ push @debugsh, '2>&1';
+
+ local $SIG{INT} = 'IGNORE';
+
+ $debugshPid = open $dsh, '-|', @debugsh
+ or error "Unable to start pipe for $opts{debugsh}", 1;
+
+ # Turn off buffering on $dsg
+ $dsh->autoflush (1);
+
+ # Temporarily turn off eval
+ my $oldEval = $CmdLine::cmdline->set_eval;
+
+ # Set DEBUGSHPID
+ $CmdLine::cmdline->_set ('DEBUGSHPID', $debugshPid);
+
+ # Turn eval back on
+ $CmdLine::cmdline->set_eval ($oldEval);
+
+ # Load our interface to DbgSh lib
+ load "$FindBin::Bin/DbgShRaidAPI", "$FindBin::Bin/lib/libDbgSh.a";
+
+ $debugshVer = GetDbgShVer ();
+
+ # Check verion of debugsh
+ my $minimumVer = '0.3.0';
+
+ error "Debugsh Version $debugshVer must be >= $minimumVer", 1
+ if compareVersions ($debugshVer, $minimumVer) == -1;
+
+ DbgShRaidRegister ($debugshPid);
+
+ if (get_debug) {
+ DbgShProcessUserInput (DBGSH_APPID, $debugshPid, 'SetDebug');
+
+ my ($result, @output) = getOutput;
+
+ $CmdLine::cmdline->_set ('result', $result);
+
+ $CmdLine::cmdline->handleOutput ('', @output);
+
+ error "$line was not successful (Result: $result)"
+ if $result;
+ } # if
+
+ return;
+} # debugshInit
+
+END {
+ terminateDebugSh;
+} # END
+
+sub interrupt () {
+ display_nolf
+ color ('yellow')
+ . '<Control-C>'
+ . color ('reset')
+ . '... '
+ . color ('red')
+ . "Abort current operation (y/N)?"
+ . color ('reset');
+
+ my $response = <STDIN>;
+ chomp;
+
+ if ($response =~ /(^y$|^yes$)/i) {
+ DbgShProcessUserInput (DBGSH_APPID, $debugshPid, 'Interrupted');
+ die "Operation aborted\n";
+ } # if
+
+ display color ('cyan') . 'Continuing...' . color ('reset');
+} # interrupt
+
+sub init () {
+ # Stop debugsh if it was running
+ terminateDebugSh;
+
+ # Intialize functions (Type 1 commands)
+ if (-d $opts{rc}) {
+ # Load %funcs with all type 1 commands. Nothing is loaded by this. Loading
+ # (actually binding) of C libraries is done automatically when the command
+ # is called.
+ %funcs = loadModules $opts{rc};
+ } else {
+ %funcs = ();
+
+ warning "Unable to find RC commands in $opts{rc}";
+ } # if
+
+ # Load commands from config file (Type 2 commands)
+ foreach (keys %opts) {
+ my $cmd;
+
+ if (/^type2_(\S+)/) {
+ $cmd = $1;
+ #$cmd =~ s/_/ /g;
+ } else {
+ next;
+ } # if
+
+ $funcs{$cmd} = {
+ appID => $opts{$_},
+ type => 2,
+ prototype => "$cmd <cmd>",
+ help => "Send <cmd> (AppID $opts{$_}) to debugsh",
+ };
+ } # foreach
+
+ # Now combine %funcs, which contain all type 1 and type 2 commands, and
+ # %raidCmds, which contain raid commands like load, unload, perl, restart,
+ # etc.
+ %allcmds = %raidCmds;
+
+ foreach (keys %funcs) {
+ $allcmds{$_} = $funcs{$_};
+ } # foreach
+
+ # Initialize debugsh
+ my $result = debugshInit;
+
+ error "Unable to initialize debugsh", $result
+ if $result;
+} # init
+
+sub compareVersions ($$) {
+ my ($version1, $version2) = @_;
+
+ $version1 =~ s/\.//g;
+ $version2 =~ s/\.//g;
+
+ return $version1 <=> $version2;
+} # compareVersions
+
+sub setVersionStr () {
+ my $raidVersionStr = color ('cyan')
+ . $name
+ . color ('reset')
+ . color ('dark')
+ . ' (Real Aid in Debugging) '
+ . color ('reset')
+ . color ('green')
+ . 'Version '
+ . color ('reset')
+ . color ('yellow')
+ . $VERSION
+ . color ('reset');
+
+ my $debugshVerStr = color ('cyan')
+ . 'Debug Shell Core '
+ . color ('green')
+ . 'Version '
+ . color ('yellow')
+ . $debugshVer
+ . color ('reset');
+
+ return $raidVersionStr . "\n" . $debugshVerStr;
+} # setVersionStr
+
+sub cmds ($%) {
+ my ($cmd, %funcs) = @_;
+
+ if (keys %funcs == 0) {
+ warning "Nothing loaded";
+ return;
+ } else {
+ my @output;
+ my @colors = (color ('dark'), color ('magenta'), color ('green'));
+
+ my $searchStr;
+
+ if ($cmd and $cmd =~ /^\s*(\w+)/) {
+ $searchStr = $1;
+ } # if
+
+ foreach (sort {
+ $funcs{$a}{type} <=> $funcs{$b}{type} ||
+ $a cmp $b
+ } keys %funcs) {
+ if ($searchStr) {
+ next
+ unless /$searchStr/i;
+ } # if
+
+ my $color = '';
+
+ $color = $colors[$funcs{$_}{type}]
+ if $colors[$funcs{$_}{type}];
+
+ my $cmdName = $_;
+
+ my $boldOn = '';
+ my $boldOff = '';
+
+ if ($funcs{$_}{type} == 1) {
+ $boldOn = color ('white on_magenta');
+ $boldOff = color ('reset') . $color;
+ } elsif ($funcs{$_}{type} == 2) {
+ $boldOn = color ('white on_green');
+ $boldOff = color ('reset') . $color;
+ } # if
+
+ if ($searchStr) {
+ $cmdName =~ s/($searchStr)/$boldOn$1$boldOff/;
+ } # if
+
+ my $line = $color . $cmdName;
+ $line .= " $funcs{$_}{parms}" if $funcs{$_}{parms};
+ $line .= color ('reset');
+ $line .= " - $funcs{$_}{help}" if $funcs{$_}{help};
+
+ push @output, $line;
+ } # foreach
+
+ $CmdLine::cmdline->handleOutput ('', @output);
+ } # if
+
+ return;
+} # cmds
+
+sub timeout (;$) {
+ my ($timeout) = @_;
+
+ my ($result, @output);
+
+ if ($timeout) {
+ if ($timeout < 0 or $timeout > 100) {
+ error "Timeout must be between 0 and 100";
+
+ $CmdLine::cmdline->_set ('result', 1);
+
+ return;
+ } # if
+
+ DbgShProcessUserInput (DBGSH_APPID, $debugshPid, "SetTimeout $timeout");
+
+ ($result, @output) = getOutput;
+
+ $CmdLine::cmdline->_set ('result', $result);
+
+ $CmdLine::cmdline->handleOutput ('', @output);
+
+ error "Unable to set timeout (Result: $result)"
+ if $result;
+ } else {
+ DbgShProcessUserInput (DBGSH_APPID, $debugshPid, 'GetTimeout');
+
+ ($result, @output) = getOutput;
+
+ $CmdLine::cmdline->_set ('result', $result);
+
+ $CmdLine::cmdline->handleOutput ('', @output);
+
+ error "Unable to get timeout (Result: $result)"
+ if $result;
+ } # if
+} # timeout
+
+sub callc ($@) {
+ my ($cmd, @parms) = @_;
+
+ # Check to see if we know about this $cmd
+ my $found;
+
+ foreach (keys %funcs) {
+ next unless /^$cmd$/i;
+
+ if ($cmd eq $_) {
+ $found = 1;
+ last;
+ } # if
+ } # foreach
+
+ unless ($found) {
+ error "Unknown command: $cmd";
+
+ return;
+ } # unless
+
+ # Check to see if the module's been loaded
+ unless ($modules{$funcs{$cmd}{module}}{loaded}) {
+ if ($funcs{$cmd}{module}) {
+ unless (load $modules{$funcs{$cmd}{module}}{moduleFile}) {
+ error "Unable to load module for $cmd";
+ return;
+ } # unless
+ } else {
+ error "Undefined module for $cmd";
+ return;
+ } # if
+ } # unless
+
+ my ($result, @output);
+
+ no strict;
+
+ eval {
+ $result = &{$funcs{$cmd}{funcname}} (@parms);
+ };
+
+ use strict;
+
+ if ($@) {
+ display_nolf $@;
+
+ return -1;
+ } else {
+ return $result
+ unless $funcs{$cmd}{type} == 1;
+
+ ($result, @output) = getOutput;
+
+ $CmdLine::cmdline->handleOutput ($cmd, @output);
+
+ return $result;
+ } # if
+} # callc
+
+sub evaluate ($) {
+ my ($line) = @_;
+
+ my $result = $CmdLine::cmdline->_get('result');
+ my @parms;
+
+ if ($line =~ /^\s*(exit|quit)\s*$/i) {
+ unless ($result) {
+ exit 0;
+ } elsif ($result =~ /^\s*(\d+)\s*$/) {
+ exit $1;
+ } else {
+ exit 1;
+ } # if
+ } elsif ($line =~ /^\s*version/i) {
+ display setVersionStr;
+ return;
+ } elsif ($line =~ /^\s*cmds\s+(.*)/i) {
+ cmds $1, %funcs;
+ return;
+ } elsif ($line =~ /^\s*cmds\s*$/i) {
+ cmds undef, %funcs;
+ return;
+ } elsif ($line =~ /^\s*restart\s*$/i) {
+ init;
+ return;
+ } elsif ($line =~ /^\s*debug\s+(\S+)/i) {
+ my @output;
+
+ if ($1 =~ /(1|on)/i) {
+ set_debug 1;
+
+ DbgShProcessUserInput (DBGSH_APPID, $debugshPid, 'SetDebug');
+
+ ($result, @output) = getOutput;
+
+ $CmdLine::cmdline->_set ('result', $result);
+
+ $CmdLine::cmdline->handleOutput ($line, @output);
+
+ error "$line was not successful (Result: $result)"
+ if $result;
+
+ return;
+ } elsif ($1 =~ /(0|off)/i) {
+ set_debug 0;
+
+ DbgShProcessUserInput (DBGSH_APPID, $debugshPid, 'ClearDebug');
+
+ ($result, @output) = getOutput;
+
+ $CmdLine::cmdline->_set ('result', $result);
+
+ $CmdLine::cmdline->handleOutput ($line, @output);
+
+ error "$line was not successful (Result: $result)"
+ if $result;
+
+ return;
+ } else {
+ error "Unknown command: $line";
+ return;
+ } # if
+ } elsif ($line =~ /^\s*timeout\s+([-+]*\d+)/i) {
+ timeout $1;
+
+ return;
+ } elsif ($line =~ /^\s*timeout\s*$/i) {
+ timeout;
+
+ return;
+ } elsif ($line =~ /^\s*debug\s*$/) {
+ if (get_debug) {
+ display 'Debug is currently on';
+ } else {
+ display 'Debug is currently off';
+ } # if
+
+ return;
+ } elsif ($line =~ /^\s*appiddisplay\s*$/i) {
+ DbgShAppIdInfo ();
+ return;
+ } elsif ($line =~ /^\s*appidclear\s+(\d+)\s*$/i) {
+ DbgShAppIdClearIdx ($1);
+ return;
+ } elsif ($line =~ /^\s*perl\s*(.*)/) {
+ # Need to turn off scrict for eval
+ eval "no strict; $1; use strict";
+
+ $result = $@ ne '';
+ } elsif ($line =~ /^\s*modules\s*$/i) {
+ modules;
+ return;
+ } elsif ($line =~ /^\s*(.+)\s*$/) {
+ my @userinput = split /[,\s\t]+/, $1;
+ my $userinput = join ' ', @userinput;
+ my $funcname = $userinput[0];
+
+ # We have a slight problem here. It is possible for a type 1 command and a
+ # type 2 command to clash. For example, if a type 1 command is defined as
+ # "ckt show id" then that will conflict with the type 2 command "ckt". In
+ # such cases which do we call?
+ #
+ # Here's what we do. We favor type 1 calls (as they are the future). If we
+ # do not find a type 1 call we'll check for a type 2. If we find neither
+ # then we have an unknown command situation.
+ #
+ # If we find a type 1 command but no type 2 then we simply execute the type
+ # 1 command.
+ #
+ # If we do not find a type 1 command but find a type 2 command then we
+ # simply execute the type 2 command.
+ #
+ # However if we find a type 1 command *and* we find a type 2 command we have
+ # and error situation so we give an error.
+
+ # Search for type 1 command
+ while ($userinput ne '') {
+ last if $funcs{$userinput} and $funcs{$userinput}{type} != 2;
+
+ unshift @parms, pop @userinput;
+
+ $userinput = join ' ', @userinput;
+ } # while
+
+ if ($userinput eq '') {
+ # No type 1 command - check type 2
+ if ($funcs{$funcname} and $funcs{$funcname}{type} == 2) {
+ my @output;
+
+ # Strip off any thing that begins with "\S+_"
+ $line =~ s/^\s*\S+_(.+)/$1/;
+
+ DbgShProcessUserInput ($funcs{$funcname}{appID}, $debugshPid, $line);
+
+ ($result, @output) = getOutput;
+
+ $CmdLine::cmdline->_set ('result', $result);
+
+ $CmdLine::cmdline->handleOutput ($line, @output);
+
+ error "$line was not successful (Result: $result)"
+ if $result;
+
+ return;
+ } else {
+ error "Unknown command: $line";
+
+ return;
+ } # if
+ } else {
+ # We've found a type 1 command but is there a clashing type 2 command?
+ if ($funcs{$funcname} and $funcs{funcname}{type} == 2) {
+ error "Clash between type 1 and type 2 commands for $funcname";
+
+ return;
+ } # if
+ } # if
+
+ # Process parms
+ foreach my $parm (@parms) {
+ # Strip () if they are there
+ $parm =~ s/^\s*\(//;
+ $parm =~ s/\)\s*$//;
+
+ # Trim
+ $parm =~ s/^\s+//;
+ $parm =~ s/\s+$//;
+
+ $parm = oct ($parm) if $parm =~ /^0/;
+ } # foreach
+
+ $result = callc $userinput, @parms;
+ } else {
+ error "Unknown command: $line";
+
+ return;
+ } # if
+
+ $CmdLine::cmdline->_set ('result', $result)
+ if $result;
+
+ return $result
+} # evalulate
+
+# Main
+$| = 1;
+
+$CmdLine::cmdline->_set ('result', 1);
+
+set_me $name;
+
+$opts{histfile} = $ENV{RAID_HISTFILE}
+ ? $ENV{RAID_HISTFILE}
+ : '.raid_hist';
+$opts{debugsh} = $ENV{RAID_DEBUGSH}
+ ? $ENV{RAID_DEBUGSH}
+ : "$FindBin::Bin/debugsh";
+$opts{load} = $ENV{RAID_LOAD}
+ ? $ENV{RAID_LOAD}
+ : undef;
+$opts{lib} = $ENV{RAID_LIB}
+ ? $ENV{RAID_LIB}
+ : undef;
+$opts{additionalLibs} = $ENV{RAID_ADDITIONALLIBS}
+ ? $ENV{RAID_ADDITIONALLIBS}
+ : '';
+$opts{rc} = $ENV{RAID_RC}
+ ? $ENV{RAID_RC}
+ : "$FindBin::Bin/rc";
+$opts{build} = 1;
+$opts{clean} = 1;
+$opts{color} = 1;
+
+GetOptions (
+ \%opts,
+ 'verbose' => sub { set_verbose },
+ 'debug' => sub { set_debug },
+ 'usage' => sub { Usage },
+ 'rc=s',
+ 'load=s',
+ 'lib=s',
+ 'histfile=s',
+ 'debugsh=s',
+ 'timeout=i',
+ 'additionallibs=s',
+ 'noisy!',
+ 'build!',
+ 'clean!',
+ 'info!',
+ 'version',
+) || Usage;
+
+if ($opts{version}) {
+ display "$name Version $VERSION";
+ exit;
+} # if
+
+$SIG{INT} = \&interrupt;
+
+init;
+
+timeout $opts{timeout} if $opts{timeout};
+
+load $opts{load}, $opts{lib}
+ if $opts{load};
+
+# Single execution from command line
+if ($ARGV[0]) {
+ my $result = evaluate join ' ', @ARGV;
+
+ $result ||= 1;
+
+ exit $result;
+} # if
+
+my ($cmd, @parms);
+
+$CmdLine::cmdline->set_histfile ($opts{histfile})
+ if $opts{histfile};
+
+$CmdLine::cmdline->set_prompt (set_prompt);
+$CmdLine::cmdline->set_cmds (%allcmds);
+$CmdLine::cmdline->set_eval (\&evaluate);
+
+while ((($line, $result) = $CmdLine::cmdline->get)) {
+ last unless defined $line;
+ next if $line =~ /^\s*($|\#)/;
+
+ $result = evaluate $line;
+
+ if (defined $result) {
+ if (ref \$result eq 'SCALAR') {
+ if ($line =~ /^\s*(\S+)/) {
+ $cmd = $1;
+ } # if
+
+ # We used to output only for raidcmds...
+ $CmdLine::cmdline->handleOutput ($line, split /\n/, $result);
+ } else {
+ display "Sorry but I cannot display structured results";
+ } # if
+ } # if
+
+ $CmdLine::cmdline->set_prompt (set_prompt $cmd);
+} # while
+
+$result = $CmdLine::cmdline->_get ('result');
+
+unless ($result) {
+ exit 0;
+} elsif ($result =~ /^\s*(\d+)\s*$/) {
+ exit $1;
+} else {
+ exit 1;
+} # if
\ No newline at end of file
--- /dev/null
+#!/usr/local/bin/perl
+################################################################################
+#
+# File: $RCSfile: rexec,v $
+# Revision: $Revision: 1.1 $
+# Description: Remotely run processes on other machines
+# Author: Andrew@ClearSCM.com
+# Created: Tue Jan 8 15:57:27 MST 2008
+# Modified: $Date: 2008/02/29 15:09:15 $
+# Language: perl
+#
+# (c) Copyright 2008, ClearSCM, Inc., all rights reserved
+#
+################################################################################
+use strict;
+use warnings;
+
+use FindBin;
+use Getopt::Long;
+use Term::ANSIColor qw(:constants);
+use POSIX ":sys_wait_h";
+
+my $libs;
+
+BEGIN {
+ $libs = $ENV{SITE_PERLLIB} ? $ENV{SITE_PERLLIB} : "$FindBin::Bin/lib";
+
+ die "Unable to find libraries\n" if !$libs and !-d $libs;
+}
+
+use lib $libs;
+
+use Display;
+use Logger;
+use Machines;
+use Rexec;
+use Utils;
+
+our $_host;
+our $_skip = 0;
+our $_currentHost;
+
+my $_log = 0;
+my $_quiet = 0;
+my $_alternateFile;
+my $_parallel = 0;
+
+my $_totalMachines = 0;
+my $_totalExecutions = 0;
+my $_totalFailures = 0;
+my $_totalConnectFailures = 0;
+my $_totalSkips = 0;
+
+my (%_workerStatuses, %_workerNames);
+
+sub Usage {
+ my $msg = shift;
+
+ display "ERROR: $msg\n" if defined $msg;
+
+ display "rexec\t[-v] [-d] [-u] <cmd>";
+ display "\t-v\tTurn on verbose mode";
+ display "\t-d\tTurn on debug mode";
+ display "\t-u\tThis usage message";
+ display "<cmd>\tCommand to execute remotely";
+
+ exit 1;
+} # Usage
+
+sub printStats {
+ display YELLOW . "Machines: " . RESET . "$_totalMachines " .
+ MAGENTA . "Executions/Failures: " . RESET . "($_totalExecutions/$_totalFailures) " .
+ BLUE . "Connect Failures/Skips: " . RESET . "($_totalConnectFailures/$_totalSkips)";
+} # printStats
+
+sub Interrupted {
+ use Term::ReadKey;
+
+ display BLUE . "\nInterrupted execution on $_host" . RESET;
+
+ printStats;
+
+ display_nolf "Executing on " . YELLOW . $_host . RESET . " - "
+ . GREEN . BOLD . "S" . RESET . GREEN . "kip" . RESET . ", "
+ . CYAN . BOLD . "C" . RESET . CYAN . "ontinue" . RESET . " or "
+ . MAGENTA . BOLD . "A" . RESET . MAGENTA . "bort run" . RESET . " ("
+ . GREEN . BOLD . "s" . RESET . "/"
+ . CYAN . BOLD . "C" . RESET . "/"
+ . MAGENTA . BOLD . "a" . RESET . ")?";
+
+ ReadMode ("cbreak");
+ my $answer = ReadKey (0);
+ ReadMode ("normal");
+
+ if ($answer eq "\n") {
+ display "c";
+ } else {
+ display $answer;
+ } # if
+
+ $answer = lc $answer;
+
+ if ($answer eq "s") {
+ *STDOUT->flush;
+ display "Skipping $_host";
+ $_skip = 1;
+ $_totalSkips++;
+ } elsif ($answer eq "a") {
+ display RED . "Aborting run". RESET;
+ printStats;
+ exit;
+ } else {
+ display "Continuing...";
+ $_skip = 0;
+ } # if
+} # Interrupted
+
+sub workerDeath {
+ while ((my $worker = waitpid (-1, WNOHANG)) > 0) {
+ my $status = $?;
+
+ # Ignore all child deaths except for processes we started
+ next if !exists $_workerStatuses{$worker};
+
+ $_workerStatuses{$worker} = $status;
+ } # while
+
+ $SIG{CHLD} = \&workerDeath;
+} # workerDeath
+
+sub execute ($$$) {
+ my ($cmd, $host, $prompt) = @_;
+
+ my @lines;
+
+ verbose_nolf "Connecting to machine $host...";
+
+ eval {
+ $_currentHost = new Rexec (
+ host => $host,
+ prompt => $prompt,
+ );
+ };
+
+ # Problem with creating Rexec object. Log error if logging and return.
+ if ($@ or !$_currentHost) {
+ if ($_log) {
+ my $log = new Logger (name => $_host);
+
+ $log->err ("Unable to connect to $host to execute command\n$cmd");
+ } # if
+
+ $_totalConnectFailures++;
+
+ return (1, ());
+ } # if
+
+ verbose " connected";
+
+ display YELLOW . "$host:" . RESET . UNDERLINE . "$cmd" . RESET unless $_quiet;
+
+ @lines = $_currentHost->exec ($cmd);
+
+ if ($_skip) {
+ # Kick current connection
+ kill INT => $_currentHost->{handle}->pid;
+ } # if
+
+ if ($_parallel != 0) {
+ if ($_log) {
+ my $log = new Logger (name => $_host);
+
+ $log->err ("Unable to connect to $host to execute command\n$cmd");
+ } # if
+
+ $_totalConnectFailures++;
+ } # if
+
+ verbose "Disconnected from $host";
+
+ my $status = $_currentHost->status;
+
+ undef $_currentHost;
+
+ return ($status, @lines);
+} # execute
+
+sub parallelize ($%) {
+ my ($cmd, %machines) = @_;
+
+ my $thread_count = 1;
+
+ foreach $_host (sort keys %machines) {
+ if ($thread_count <= $_parallel) {
+ debug "Processing $_host ($thread_count)";
+ $thread_count++;
+
+ if (my $pid = fork) {
+ # In parent process - record this host and its status
+ $_workerNames{$pid} = $_host;
+ } else {
+ # In spawned child...
+ $pid = $$;
+
+ debug "Starting process for $_host [$pid]";
+
+ $_workerNames{$pid} = $_host;
+
+ my ($status, @lines) = execute $cmd, $_host, $machines{$_host};
+
+ my $log = new Logger (name => $_host);
+
+ $log->log ($_) foreach (@lines);
+
+ exit $status;
+ } # if
+ } else {
+ # Wait for somebody to finish;
+ debug "Waiting for somebody to exit...";
+ my $reaped = wait;
+
+ debug "Reaped $_workerNames{$reaped} [$reaped] (Status: $?)";
+ $_workerStatuses{$reaped} = $? >> 8 if $reaped != -1;
+
+ $thread_count--;
+ } # if
+ } # foreach
+
+ # Wait for all kids
+ my %threads = %_workerNames;
+
+ foreach (keys %threads) {
+ if (waitpid ($_, 0) == -1) {
+ delete $threads{$_};
+ } else {
+ $_workerStatuses{$_} = $? >> 8;
+ debug "$threads{$_} [$_] exited with a status of $_workerStatuses{$_}";
+ } # if
+ } # foreach
+
+ debug "All processed completed - Status:";
+
+ if (get_debug) {
+ foreach (sort keys %_workerStatuses) {
+ debug "$_workerNames{$_}\t[$_]:\tStatus: $_workerStatuses{$_}";
+ } # foreach
+ } # if
+
+ # Gather output...
+ display "Output of all executions";
+ foreach $_host (sort keys %machines) {
+ if (-f "$_host.log") {
+ display "$_host:$_" foreach (ReadFile ("$_host.log"));
+
+ #unlink "$_host.log";
+ } else {
+ warning "Unable to find output for $_host ($_host.log missing)";
+ } # if
+ } # foreach
+} # parallelize
+
+# Print the totals if interrupted
+$SIG{INT} = \&Interrupted;
+
+# Get our options
+GetOptions (
+ "usage" => sub { Usage "" },
+ "verbose" => sub { set_verbose },
+ "debug" => sub { set_debug },
+ "log" => \$_log,
+ "quiet" => \$_quiet,
+ "file=s" => \$_alternateFile,
+ "parallel:i" => \$_parallel,
+) || Usage "Unknown parameter";
+
+my $cmd = join " ", @ARGV;
+
+error "No command specified", 1 if !$cmd;
+
+my $machines = Machines->new (file => $_alternateFile);
+my %machines = $machines->all ();
+
+if ($_parallel > 0) {
+ parallelize ($cmd, %machines);
+ printStats;
+ exit;
+} # if
+
+display "NOTE: Logging output to <host>.log" if $_log;
+
+foreach $_host (sort keys (%machines)) {
+ $_totalMachines++;
+
+ my ($status, @lines) = execute $cmd, $_host, $machines{$_host};
+
+ if ($_skip) {
+ $_skip = 0;
+ next;
+ } # if
+
+ if (defined $status) {
+ if ($status == 0) {
+ $_totalExecutions++;
+ } else {
+ if ($_log) {
+ my $log = new Logger (name => $_host);
+
+ $log->err ("Unable to execute command on $_host\n$cmd");
+ } # if
+
+ $_totalFailures++;
+
+ next;
+ } # if
+ } # if
+
+ if ($_log) {
+ my $log = new Logger (name => $_host);
+
+ $log->log ($_) foreach (@lines);
+ } else {
+ display $_ foreach (@lines);
+ } # if
+} # foreach
+
+printStats;
\ No newline at end of file
--- /dev/null
+#!/bin/bash
+################################################################################
+#
+# File: $RCSfile: root,v $
+# Revision: $Revision: 1.4 $
+# Description: Run a command/shell as root
+# Author: Andrew@DeFaria.com
+# Created: Mon Nov 13 16:14:30 1995
+# Modified: $Date: 2010/06/08 15:03:27 $
+# Language: Bash
+#
+# (c) Copyright 2000-2005, ClearSCM, Inc., all rights reserved.
+#
+################################################################################
+if [ $# -gt 0 ]; then
+ # Execute the commands
+ sudo "$@"
+else
+ # Become a "wizard"!
+ # Source in profile
+ if [ -f ~/.rc/profile ]; then
+ . ~/.rc/profile
+ fi
+
+ # Source in functions (needed for set_title and set_prompt)
+ if [ -f ~/.rc/functions ]; then
+ . ~/.rc/functions
+ fi
+
+ sudo -s
+
+ # Reset title and prompt
+ # Note: I don't like doing this but an alias doesn't work...
+ if [ $ARCH = "sun" ]; then
+ id=/usr/xpg4/bin/id
+ else
+ id=id
+ fi
+
+ set_title
+ set_prompt
+fi
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: setbg,v $
+
+Set background
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision:
+
+$Revision: 1.10 $
+
+=item Created:
+
+Fri Mar 18 01:14:38 PST 2005
+
+=item Modified:
+
+$Date: 2012/11/09 15:31:30 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage: setbg [-u|sage] [-ve|rbose] [-d|ebug] [-s|leep <n>] [-bgdir <bgdir>]
+
+ Where:
+
+ -u|sage: Displays this usage
+ -ve|rbose: Be verbose
+ -d|ebug: Output debug messages
+
+ -s|leep: Number of minutes to sleep between setting the background
+ (Default: 1 hour)
+ -b|gdir: Directory to scan for images (Default: /web/Pictures)
+
+=head1 DESCRIPTION
+
+This script sets the background image randomly based on images $imgDir. Note
+if this script is run again it senses that it was previously run and sends the
+previous script a SIGUSR2 which the script intrprets as "Change the background
+now", then exits.
+
+=cut
+
+use strict;
+use warnings;
+
+use FindBin;
+use Getopt::Long;
+use Proc::ProcessTable;
+
+use lib "$FindBin::Bin/../lib";
+
+use Display;
+use Utils;
+
+my $VERSION = '$Revision: 1.10 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+my $processes = new Proc::ProcessTable;
+
+foreach my $process (@{$processes->table}) {
+ if ($process->cmndline =~ /setbg/ and
+ $process->pid != $$) {
+ kill 12, $process->pid;
+
+ exit 0;
+ } # if
+} # foreach
+
+$0 = "$FindBin::Script " . join ' ', @ARGV;
+
+verbose "$FindBin::Script v$VERSION";
+
+my $sleep = 60 * 60;
+my $imgDir = $ENV{SETBG_DIR} ? $ENV{SETBG_DIR} : '/web/Pictures';
+
+GetOptions (
+ 'usage' => sub { Usage },
+ 'verbose' => sub { set_verbose },
+ 'debug' => sub { set_debug },
+ 'sleep=i' => \$sleep,
+ 'bgdir=s' => \$imgDir,
+) || Usage;
+
+error "$imgDir is not a directory", 1 unless -d $imgDir;
+
+# Using gsettings
+my $setbg = "gsettings";
+my $setbgOpts = "set org.gnome.desktop.background picture-uri \"file://";
+
+chomp (my @images = `find $imgDir -type f -name "*.jpg"`);
+
+sub SwitchWallPaper {
+ # We don't need to do anything here, just handle the interrupt and
+ # let the while loop continue.
+ debug 'SwitchWallPaper: Interrupt received';
+} # SwitchWallPaper
+
+$SIG{USR2} = \&SwitchWallPaper;
+
+my $debugger = $DB::OUT;
+
+EnterDaemonMode unless defined $DB::OUT;
+
+while () {
+ my $image = $images[int (rand $#images)];
+
+ open my $log, '>', "$ENV{HOME}/.$FindBin::Script"
+ or error "Unable to open $ENV{HOME}/.setbg for writing - $!", 1;
+
+ display "Current background: $image", $log;
+
+ my $cmd = "$setbg $setbgOpts$image\" 2> /dev/null";
+
+ `$cmd`;
+
+ close $log;
+
+ sleep $sleep;
+} # while
--- /dev/null
+#!/bin/bash
+################################################################################
+#
+# File: $RCSfile: setup_cron,v $
+# Revision: $Revision: 1.2 $
+# Description: This script sets up Cygwin's cron on the local machine
+# Author: Andrew@DeFaria.com
+# Created: Somewhere in 2003 or so...
+# Modified: $Date: 2010/06/08 15:03:27 $
+# Language: Bash
+#
+# (c) Copyright 2002, ClearSCM, Inc., all rights reserved
+#
+################################################################################
+me=$(basename $0)
+# Make sure that certain directories and files do not exist! This is to let
+# cron create them, which appears to be the only way to get these created
+# correctly!
+if [ ! -d /var/cron ]; then
+ rm -rf /var/cron
+ rm -rf /var/run/cron.pid
+ rm -rf /var/log/cron.log
+
+ # Install cron service:
+ cygrunsrv -I cron -p /usr/sbin/cron -a -D -d "Cygwin cron" -e "MAILTO=$USER@Salira.com" -e "CYGWIN=ntsec"
+fi
+
+# Start cron service
+cygrunsrv -S cron
--- /dev/null
+#!/bin/bash
+################################################################################
+#
+# File: $RCSfile; $
+# Revision: $Revision: 1.2 $
+# Description: This script sets up ssmtp mail configuration
+# Author: Andrew@DeFaria.com
+# Created: Wed Jan 9 12:57:13 2002
+# Modified: $Date: 2010/06/08 15:03:27 $
+# Language: Bash
+#
+# (c) Copyright 2002, ClearSCM, Inc., all rights reserved
+#
+################################################################################
+# Setup /etc/ssmtp config directory
+ssmtp_dir=/etc/ssmtp
+domain=$1
+mail_server=$2
+me=$(basename $0)
+
+function usage {
+ msg="$1"
+
+ echo "$me: <mail_server> <domain>"
+
+ if [ ! -z "$msg" ]; then
+ echo $msg
+ fi
+
+ exit 1
+} # usage
+
+if [ -z "$mail_server" ]; then
+ usage "Mail_server not specified"
+fi
+
+if [ -z "$domain" ]; then
+ usage "Domain not specified"
+fi
+
+mkdir -p $ssmtp_dir
+chmod 700 $ssmtp_dir
+
+# Make some simple aliases. Alias $USER to the proper email address and then
+# alias root, Administrator and postmaster to the user's address thus making
+# the user "god" of smtp on this machine only.
+cat > $ssmtp_dir/revaliases <<EOF
+# sSMTP aliases
+#
+# Format: local_account:outgoing_address:mailhub
+#
+# Example: root:your_login@your.domain:mailhub.your.domain:[port]
+# where [port] is an optional port number that defaults to 25.
+$USER:$USER@$domain:$mail_server:25
+root:$USER@$domain:$mail_server:25
+Administrator:$USER@$domain:$mail_server:25
+postmaster:$USER@$domain:$mail_server:25
+EOF
+
+# Get a downshifted hostname
+hostname=$(hostname | tr '[:upper:]' '[:lower:]')
+
+# Make ssmtp.conf
+cat > $ssmtp_dir/ssmtp.conf <<EOF
+# ssmtp.conf: Config file for Cygwin's sstmp sendmail
+#
+# The person who gets all mail for userids < 10
+root=postmaster
+# The place where the mail goes. The actual machine name is required
+# no MX records are consulted. Commonly mailhosts are named mail.domain.com
+# The example will fit if you are in domain.com and you mailhub is so named.
+mailhub=$mail_server
+# Where will the mail seem to come from?
+#rewriteDomain=$USER.$domain
+# The full hostname
+hostname=$hostname.$domain
+# Set this to never rewrite the "From:" line (unless not given) and to
+# use that address in the "from line" of the envelope.
+#FromLineOverride=YES
+EOF
--- /dev/null
+=head1 NAME
+
+Diffbl.pm: Perl/Tk UI for diffbl.pl
+
+=head1 USAGE
+
+ use DiffBLUI.pm;
+
+ CreateUI;
+
+=head1 DESCRIPTION
+
+This Perl module encapsulates the Perl/Tk UI for diffbl.pl.
+
+=head1 AUTHOR
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2010 Andrew DeFaria <Andrew@ClearSCM.com>, ClearSCM, Inc.
+All rights reserved.
+
+=cut
+
+package DiffBLUI;
+
+use strict;
+use warnings;
+
+use Cwd;
+use POSIX;
+use Tk;
+use Tk::BrowseEntry;
+use Tk::DialogBox;
+use Tk::ROText;
+
+use lib '../lib';
+
+use Clearcase;
+use Display;
+use OSDep;
+
+use CCDBService;
+
+use base 'Exporter';
+
+my $VERSION = '1.0';
+
+our (
+ %SELECTED,
+ %LINES,
+ $MODE,
+ $INTEGRATIONACTIVITIES,
+ $integrationActivitiesCheck
+);
+
+my ($msgWidget, $searchPattern);
+
+our @EXPORT = qw (
+ createUI
+ displayLines
+ Tkerror
+ Tkmsg
+);
+
+# Globals
+my $TITLE = 'Compare Baselines: Use fields to select baselines then ';
+ $TITLE .= 'select Compare';
+
+my $CCDBService = CCDBService->new;
+
+# Widgets
+my (
+ $main,
+ $versionsMenu,
+ $activitiesMenu,
+ $pvobDropdown,
+ $streamDropdown,
+ $fromBaselineDropdown,
+ $toBaselineDropdown,
+ $compareButton,
+ $output,
+);
+
+# Data
+my (@pvobs, @streams, @fromBaselines, @toBaselines);
+
+sub createButton ($$$) {
+ my ($parent, $label, $action) = @_;
+
+ $parent->Button (
+ -text => $label,
+ -width => length $label,
+ -command => \$action
+ )->pack (
+ -side => "left",
+ -padx => 5,
+ -pady => 5,
+ );
+
+ return;
+} # createButton
+
+sub createDropdown ($$$;$$) {
+ my ($parent, $label, $variable, $action, $list) = @_;
+
+ my $widget = $parent->BrowseEntry (
+ -label => "$label:",
+ -font => 'Arial 8 bold',
+ -variable => $variable,
+ -width => 175,
+ -takefocus => 1,
+ )->pack (
+ -padx => 5,
+ -pady => 2,
+ );
+
+ if ($action) {
+ # Any of these cause the action to be invoked
+ $widget->configure (-browsecmd => \$action);
+ $widget->bind ('<FocusOut>' => \$action);
+ $widget->bind ('<Return>' => \$action);
+ } # if
+
+ $widget->configure (-listcmd => \$list)
+ if $list;
+
+ my $listBox = $widget->Subwidget ('slistbox');
+ my $entry = $widget->Subwidget ('entry');
+ my $arrow = $widget->Subwidget ('arrow');
+ my $choices = $widget->Subwidget ('choices');
+
+ # Turn off bolding on the entry
+ $entry->configure (-font => 'Arial 8');
+
+ # Allow both widgets to have highlighted parts
+ $listBox->configure (-exportselection => 0);
+ $entry->configure (-exportselection => 0);
+
+ # Take the arrow out of the focus business - Works on Unix!
+ # Bug on Windows! :-(
+ $arrow->configure (-takefocus => 0);
+
+ # This gets the mouse wheel working - Works on Unix!
+ # Bug on Windows! :-(
+ $choices->bind ('<Button-4>', sub {$choices->yviewScroll (1,'units')});
+ $choices->bind ('<Button-5>', sub {$choices->yviewScroll (-1,'units')});
+ $choices->bind ('<Button-4>', sub {$choices->yview (1,'units')});
+ $choices->bind ('<Button-5>', sub {$choices->yview (-1,'units')});
+
+ foreach (
+ '<KeyPress>',
+ '<Up>',
+ '<Down>',
+ '<Control-Key-p>',
+ '<Control-Key-n>'
+ ) {
+ $entry->bind ($_, [\&handleKeypress, $listBox]);
+ } # foreach
+
+ return $widget;
+} # createDropdown
+
+sub createList ($) {
+ my ($parent) = @_;
+
+ my $widget = $parent->Scrolled ('Listbox',
+ -height => 10,
+ -width => 100,
+ -scrollbars => 'e',
+ )->pack (
+ -padx => 5,
+ -pady => 5,
+ -fill => 'both',
+ -expand => 'yes',
+ -anchor => 'w',
+ );
+
+ # Make this list resizeable
+ $parent->pack (
+ -fill => 'both',
+ -expand => 'yes',
+ );
+
+ # Bind actions
+ $widget->bind ('<ButtonPress-3>', [ \&popupCCActions, Ev('@') ]);
+ $widget->bind ('<Double-ButtonPress-1>', \&properties);
+
+ # This gets the mouse wheel working
+ $widget->bind ('<Button-4>', sub {$widget->yviewScroll (1,'units')});
+ $widget->bind ('<Button-5>', sub {$widget->yviewScroll (-1,'units')});
+
+ return $widget;
+} # createList
+
+sub setList ($@) {
+ my ($list, @value) = @_;
+
+ $list->insert ('end', $_)
+ foreach @value;
+
+ return;
+} # setList
+
+sub clearList($) {
+ my ($list) = @_;
+
+ return
+ unless $list;
+
+ $list->delete ('0.0', 'end');
+
+ return;
+} # clearList
+
+sub search (@) {
+ my (@values) = @_;
+
+ return (undef, ())
+ unless length $searchPattern;
+
+ my ($index, @matches);
+
+ # First filter @values including only matching entries
+ foreach (@values) {
+ push @matches, $_
+ if /$searchPattern/i;
+ } # foreach
+
+ @values = ();
+
+ # Now determine the first qualifying entry. Note if index is already set then
+ # we do not need to recompute it. It was computed above via a Up or Down key.
+ foreach (0 .. $#matches) {
+ if ($matches[$_] =~ m/$searchPattern/i) {
+ push @values, $matches[$_];
+ $index = $_ unless defined $index;
+ } # if
+ } # foreach
+
+ return ($index, @values);
+} # search
+
+sub setDropdown ($$$) {
+ my ($listBox, $entry, $index) = @_;
+
+ # Set listBox widget. This is actually the dropdown list.
+ $listBox->see ($index);
+ $listBox->activate ($index);
+
+ # This should be the active entry to set into the entry widget
+ my $currentEntry = $listBox->get ($index);
+
+ # Set the entry widget. This is the line that the user is typing in
+ $entry->delete (0, 'end');
+ $entry->insert (0, $currentEntry);
+
+ # Set the selection highlight (if the searchPattern is found)
+ unless (length $searchPattern == 0) {
+ if ($currentEntry =~ /$searchPattern/i) {
+ $entry->selectionClear;
+ $entry->selectionRange ($-[0], $+[0]);
+ $entry->icursor ($+[0]);
+ } # if
+ } # unless
+
+ return;
+} # setDropdown
+
+sub handleKeypress {
+ my ($entry, $listBox) = @_;
+
+ my (@matches, $match, $index);
+
+ # This is ugly but works
+ my $browseEntry = $listBox->parent->parent;
+
+ my $key = $entry->XEvent->A;
+ my $keysym = $entry->XEvent->K;
+
+ debug "Entry: " . $entry->get;
+ debug "Key: '$key' ($keysym)";
+
+ # Map Cntl-n and Cntl-p to Down and Up
+ $keysym = 'Down' if ord ($key) == 14;
+ $keysym = 'Up' if ord ($key) == 16;
+
+ my $first = 0;
+ my $Last = $listBox->index ('end') - 1; # Make 0 relative
+ my $active = $listBox->index ('active');
+
+ $index = $active;
+
+ if ($keysym eq 'BackSpace') {
+ $searchPattern = substr $searchPattern, 0, -1
+ if length $searchPattern > 0;
+
+ if (length $searchPattern == 0) {
+ $index = 0;
+ $entry->delete (0, 'end');
+ } # if
+ } elsif ($keysym eq 'Down') {
+ if ($active < $Last) {
+ setDropdown ($listBox, $entry, ++$active);
+ } else {
+ debug "Beep - no more down";
+ $main->bell;
+ } # if
+
+ return;
+ } elsif ($keysym eq 'Up') {
+ if ($active > 0) {
+ setDropdown ($listBox, $entry, --$active);
+ } else {
+ debug "Beep - no more up";
+ $main->bell;
+ } # unless
+
+ return;
+ } elsif ($keysym eq 'Tab') {
+ $entry->selectionClear;
+
+ return;
+ } else {
+ return if (!isprint ($key) || !ord ($key));
+
+ $searchPattern .= $key;
+ } # if
+
+ debug "searchPattern: $searchPattern";
+
+ # Get values based on the $browseEntry widget
+ my @values;
+
+ unless ($index) {
+ do {
+ if ($browseEntry == $pvobDropdown) {
+ ($index, @values) = search sort @pvobs;
+ } elsif ($browseEntry == $streamDropdown) {
+ ($index, @values) = search sort @streams;
+ } elsif ($browseEntry == $fromBaselineDropdown) {
+ ($index, @values) = search sort @fromBaselines;
+ } elsif ($browseEntry == $toBaselineDropdown) {
+ ($index, @values) = search sort @toBaselines;
+ } # if
+
+ if (defined $index) {
+ debug "Index: $index";
+ $match = $values[$index];
+ } else {
+ debug "Index: <undefined>";
+ debug "Length of searchPatern " . length $searchPattern;
+ if (length $searchPattern == 0) {
+ debug "Setting match to blank";
+ $match = '';
+ $index = 0;
+ } else {
+ debug "making searchPattern shorter";
+ $searchPattern = substr $searchPattern, 0, -1;
+ debug "Length of searchPatern now " . length $searchPattern;
+ } # if
+ } # if
+ } until $match or length $searchPattern == 0;
+ } # unless
+
+ # Setting the listBox clears the active indicator so save it and reset it.
+ $active = $listBox->index ('active');
+
+ clearList $listBox;
+ setList $listBox, sort @values;
+
+ $listBox->activate ($active);
+
+ if ($searchPattern) {
+ if ($match and $match =~ /$searchPattern/i) {
+ $entry->delete (0, 'end');
+ $entry->selectionClear;
+ $entry->insert (0, $match);
+ $entry->icursor ($+[0]);
+ $entry->selectionRange ($-[0], $+[0]);
+ } else {
+ debug "Beep - no matches";
+ $main->bell;
+ return;
+ } # if
+ } # if
+
+ # Now update the assocated listBox.
+ $listBox->selectionClear (0, 'end');
+ $listBox->selectionSet ($index, $index);
+
+ # Makes it so that the entry selected above is centered in the drop down list.
+ # So if you had say entries like 1, 2, 3, 4,... 10 and you hit '5', you'll see
+ # '5' in the listBox entry but you really want to also shift it so that if you
+ # hit the drop down arrow, 5, is the entry at the top of the drop down list.
+ $listBox->see ($index);
+
+ debug 'Entry: ' . $entry->get;
+
+ return;
+} # handleKeypress
+
+sub Tkerror ($) {
+ my ($msg) = @_;
+
+ my $error = $main->DialogBox (
+ -title => 'Error',
+ -buttons => [ 'OK' ],
+ );
+
+ my $text = $error->add (
+ 'ROText',
+ -width => 65,
+ -height => 8,
+ -font => "Arial 8",
+ -wrap => 'word',
+ )->pack (
+ -fill => 'both',
+ -expand => 1,
+ );
+
+ $text->insert ('end', $msg);
+
+ $error->Show;
+
+ return;
+} # Tkerror
+
+sub Tkmsg ($;$) {
+ my ($msg, $sleep) = @_;
+
+ if ($msgWidget) {
+ $msgWidget->configure (-text => $msg);
+ $msgWidget->update;
+
+ if ($sleep) {
+ return
+ if $sleep < 0;
+
+ sleep $sleep;
+ } # if
+
+ $msgWidget->configure (-text => '');
+ $msgWidget->update;
+ } # if
+
+ return;
+} # Tkmsg
+
+sub about () {
+ my $msg = "Utility to select baselines and provide a simple list of "
+ . "activities or file/directory versions that differ between "
+ . "two baselines.\n\n"
+ . "Note you can save this list using the Save button or you can "
+ . "right click on a line and select Clearcase operations.\n\n"
+ . "Written by Andrew DeFaria <Andrew\@ClearSCM.com>";
+
+ my $about = $main->DialogBox (
+ -title => "About $FindBin::Script V$VERSION",
+ -buttons => [ 'OK' ],
+ );
+
+ my $text = $about->add (
+ 'ROText',
+ -width => 65,
+ -height => 8,
+ -font => "Arial 8",
+ -wrap => 'word',
+ )->pack;
+
+ # Stop about dialog from resizing
+ $about->bind (
+ '<Configure>' => sub {
+ my $e = $about->XEvent;
+
+ $about->maxsize ($e->w, $e->h);
+ $about->minsize ($e->w, $e->h);
+ },
+ );
+
+ $text->insert ('end', $msg);
+
+ $about->Show;
+
+ return;
+} # about
+
+sub popupCCActions ($) {
+ my ($widget, $xy) = @_;
+
+ $widget->selectionClear (0, 'end');
+
+ my $index = $widget->index ($xy);
+ my $event = $widget->XEvent;
+
+ if (defined $index) {
+ $widget->selectionSet ($index);
+
+ if ($MODE eq 'versions') {
+ $versionsMenu->post ($widget->rootx + $event->x, $widget->rooty + $event->y);
+ } else {
+ $activitiesMenu->post ($widget->rootx + $event->x, $widget->rooty + $event->y);
+ }
+ } # if
+
+ return;
+} # popupCCActions
+
+sub busy () {
+ $main->Busy (-recurse => 1);
+ $main->update;
+
+ return;
+} # busy
+
+sub unbusy () {
+ $main->Unbusy;
+ $main->update;
+
+ return;
+} # unbusy
+
+sub getPvobs {
+ $main->Busy (-recurse => 1);
+
+ my ($status, @output) = $Clearcase::CC->execute ('lsvob');
+
+ @pvobs = ();
+
+ foreach (grep { /\(ucmvob/ } @output) {
+ my @tokens = split;
+
+ my $pvob = $tokens[0] eq '*'
+ ? Clearcase::vobname ($tokens[1])
+ : Clearcase::vobname ($tokens[0]);
+
+ push @pvobs, $pvob;
+ } # foreach
+
+ clearList $streamDropdown; $SELECTED{stream} = '';
+ $streamDropdown->update;
+ clearList $fromBaselineDropdown; $SELECTED{fromBaseline} = '';
+ $fromBaselineDropdown->update;
+ clearList $toBaselineDropdown; $SELECTED{toBaseline} = '';
+ $toBaselineDropdown->update;
+ clearList $output;
+
+ clearList $pvobDropdown;
+ setList $pvobDropdown, sort @pvobs;
+
+ $main->Unbusy;
+
+ return;
+} # getPvobs
+
+sub getStreams () {
+ $main->Busy (-recurse => 1);
+
+ $searchPattern = '';
+
+ clearList $streamDropdown;
+
+ $SELECTED{stream} = 'Getting streams...';
+
+ $streamDropdown->update;
+
+ my $pvob = Clearcase::vobname ($SELECTED{pvob});
+
+ $CCDBService->connectToServer
+ or error "Unable to connect to CCDBService", 1;
+
+ my ($status, $streams) = $CCDBService->execute ("FindStream * $pvob");
+
+ $CCDBService->disconnectFromServer;
+
+ if ($status) {
+ Tkerror "Unable to get streams (Status: $status)\n" . join ("\n", @$output);
+ return;
+ } # if
+
+ # First empty @streams of the old contents
+ @streams = ();
+
+ push @streams, $$_{name}
+ foreach (@$streams);
+
+ clearList $fromBaselineDropdown;
+ clearList $toBaselineDropdown;
+
+ $SELECTED{fromBaseline} = '';
+ $SELECTED{toBaseline} = '';
+
+ $fromBaselineDropdown->update;
+ $toBaselineDropdown->update;
+
+ clearList $output;
+
+ $SELECTED{stream} = '';
+
+ setList $streamDropdown, sort @streams;
+
+ $streamDropdown->focus;
+
+ $main->Unbusy;
+
+ return;
+} # getStreams
+
+sub getBaselines () {
+ $main->Busy (-recurse => 1);
+
+ $searchPattern = '';
+
+ my $status;
+
+ clearList $fromBaselineDropdown;
+ clearList $toBaselineDropdown;
+
+ $SELECTED{fromBaseline} = 'Getting baselines...';
+ $SELECTED{toBaseline} = 'Getting baselines...';
+
+ $fromBaselineDropdown->update;
+ $toBaselineDropdown->update;
+
+ ($status, @fromBaselines) = $Clearcase::CC->execute
+ ("lsbl -short -stream $SELECTED{stream}\@$Clearcase::VOBTAG_PREFIX$SELECTED{pvob}");
+
+ @toBaselines = @fromBaselines;
+
+ clearList $fromBaselineDropdown;
+ clearList $toBaselineDropdown;
+
+ $SELECTED{fromBaseline} = '';
+ $SELECTED{toBaseline} = '';
+
+ $fromBaselineDropdown->update;
+ $toBaselineDropdown->update;
+
+ clearList $output;
+
+ setList $fromBaselineDropdown, sort @fromBaselines;
+ setList $toBaselineDropdown, sort @toBaselines;
+
+ $main->Unbusy;
+
+ return;
+} # getBaselines
+
+sub saveList () {
+ my @types = (
+ ['Text Files', '.txt', 'TEXT'],
+ ['All Files', '*']
+ );
+
+ my $filename = $main->getSaveFile (
+ -filetype => \@types,
+ -initialfile => "$SELECTED{fromBaseline}.$SELECTED{toBaseline}.diffs",
+ -defaultextension => '.txt',
+ );
+
+ return unless $filename;
+
+ open my $file, '>', $filename
+ or Tkmsg "Unable to open $filename for writing - $!", -1
+ and return;
+
+ foreach ($output->get (0, 'end')) {
+ print $file "$_\n";
+ } # foreach
+
+ close $file;
+
+ return;
+} # saveList
+
+sub childDeath () {
+ my $pid = wait;
+
+ display "$pid died";
+
+ CORE::exit;
+
+ return;
+} # childDeath
+
+local $SIG{CLD} = \&childDeath;
+local $SIG{CHLD} = \&childDeath;
+
+sub ccexec ($;$$) {
+ my ($cmd, $parm1, $parm2) = @_;
+
+ unless ($parm1) {
+ my $selected = $output->curselection;
+
+ return
+ unless $selected;
+
+ my $line = $output->get ($selected);
+
+ if ($MODE eq 'versions') {
+ # Need to add on the view tag prefix
+ $cmd .= " $Clearcase::VIEWTAG_PREFIX/" . $::view->tag . $line;
+ } else {
+ $cmd .= " activity:$line\@";
+ $cmd .= Clearcase::vobtag $SELECTED{pvob};
+ } # if
+ } else {
+ $cmd .= " $parm1 $parm2";
+ } # unless
+
+ $main->Busy (-recurse => 1);
+
+ if ($ARCH eq 'windows' or $ARCH eq 'cygwin') {
+ $Clearcase::CC->execute ($cmd);
+ } else {
+ # Use fork/exec to allow CC processes to not cause us to block
+ unless (fork) {
+ $Clearcase::CC->execute ($cmd);
+ CORE::exit;
+ } # unless
+ } # if
+
+ $main->Unbusy;
+
+ return
+} # ccexec
+
+sub findVersion ($$) {
+ my ($element, $baseline) = @_;
+
+ my $cmd = 'find ' . substr ($element, 1) . ' -directory ';
+ $cmd .= "-version 'lbtype($baseline)' -print";
+
+ my ($status, @output) = $Clearcase::CC->execute ($cmd);
+
+ if ($status) {
+ my $msg = "Unable to determine the version for $element ($baseline)";
+
+ Tkerror join ("\n", "$msg (Status: $status)", "\n", @output);
+
+ exit $status;
+ } # if
+
+ # Change these silly '\'s -> '/'s
+ $output[0] =~ s/\\/\//g;
+
+ my $version;
+
+ if ($output[0] =~ /.*$Clearcase::SFX(.*)/) {
+ $version = $1;
+ } # if
+
+ return $version
+} # findVersion
+
+sub compareToPrev () {
+ my $selected = $output->curselection;
+
+ return
+ unless $selected;
+
+ my $element = $output->get ($selected);
+
+ # Need to add on the view tag prefix
+ my $element1 = "$Clearcase::VIEWTAG_PREFIX/" . $::view->tag . $element;
+ my $element2 = "$Clearcase::VIEWTAG_PREFIX/" . $::view->tag . $element;
+
+ # Get into the view context
+ my $view_context = $Clearcase::VIEWTAG_PREFIX . '/' . $::view->tag;
+ my $cwd = getcwd;
+
+ # For my Cygwin environment - translate that path back into a Windows path
+ if ($ARCH eq 'cygwin') {
+ my @cwd = `cygpath -w $cwd`;
+ chomp @cwd;
+
+ $cwd = $cwd[0];
+ } # if
+
+ my ($status, @output) = $Clearcase::CC->execute ("cd \"$view_context\"");
+
+ Tkerror "Unable to set view context to $view_context (Status: $status)" .
+ join ("\n", @output)
+ if $status;
+
+ my $version;
+
+ # Determine from baseline version
+ $version = findVersion $element, $SELECTED{fromBaseline};
+ $element1 .= "$Clearcase::SFX$version";
+
+ # Determine to baseline version
+ $version = findVersion $element, $SELECTED{toBaseline};
+ $element2 .= "$Clearcase::SFX$version";
+
+ ccexec 'diff -g', $element1, $element2;
+
+ return;
+} # compareToPrev
+
+sub history () {
+ ccexec 'lshist -g';
+
+ return;
+} # history
+
+sub versionTree () {
+ ccexec 'lsvtree -g';
+
+ return;
+} # versionTree
+
+sub properties () {
+ ccexec 'describe -g';
+
+ return;
+} # properties
+
+sub displayLines () {
+ clearList $output;
+
+ my @lines = keys %LINES;
+
+ if ($MODE eq 'activities') {
+ @lines = grep {!/(deliver|rebase|tlmerge|integrate)/} @lines
+ unless $INTEGRATIONACTIVITIES;
+ } # if
+
+ setList $output, sort @lines;
+
+ my $msg = @lines > 0 ? @lines : 'No';
+ $msg .= $MODE eq 'versions' ? ' Element' : ' Activit';
+
+ if ($MODE eq 'versions') {
+ $msg .= 's'
+ if @lines != 1;
+ } else {
+ if (@lines != 1) {
+ $msg .= 'ies';
+ } else {
+ $msg .= 'y';
+ } # if
+ } # if
+
+ Tkmsg $msg, 3;
+
+ return;
+} # displayLines
+
+sub setFocus () {
+ my ($entry) = @_;
+
+ $searchPattern = '';
+ $entry->icursor (0);
+
+ return;
+} # setFocus
+
+sub createUI () {
+ $main = MainWindow->new;
+
+ # Set an icon image
+ $main->iconimage ($main->Photo (-file => "$FindBin::Bin/diffbl.gif"))
+ if -f "$FindBin::Bin/diffbl.gif";
+
+ my $WIDTH = (length ($TITLE) + 1) * 10;
+
+ $main->geometry ("${WIDTH}x600");
+ $main->title ("$FindBin::Script V$VERSION");
+
+ my @frame;
+
+ for (my $i = 0; $i < 9; $i++) {
+ $frame[$i] = $main->Frame->pack;
+ } # for
+
+ # Create versions popup menu
+ $versionsMenu = $main->Menu (
+ -tearoff => 0,
+ );
+
+ $versionsMenu->add (
+ 'command',
+ -label => 'Compare to Prev',
+ -command => \&compareToPrev,
+ );
+ $versionsMenu->add (
+ 'command',
+ -label => 'History',
+ -command => \&history,
+ );
+ $versionsMenu->add (
+ 'command',
+ -label => 'Version Tree',
+ -command => \&versionTree,
+ );
+ $versionsMenu->add (
+ 'command',
+ -label => 'Properties',
+ -font => 'Arial 8 bold',
+ -command => \&properties,
+ );
+
+ # Create activities popup menu
+ $activitiesMenu = $main->Menu (
+ -tearoff => 0,
+ );
+
+ $activitiesMenu->add (
+ 'command',
+ -label => 'Show Contributing Activities',
+ -state => 'disable',
+ -command => [ \&Tkerror, "Unimplemented" ],
+ );
+ $activitiesMenu->add (
+ 'command',
+ -label => 'Checkin All',
+ -state => 'disable',
+ -command => [ \&Tkerror, "Unimplemented" ],
+ );
+ $activitiesMenu->add (
+ 'command',
+ -label => 'Finish Activity',
+ -state => 'disable',
+ -command => [ \&Tkerror, "Unimplemented" ],
+ );
+ $activitiesMenu->add (
+ 'command',
+ -label => 'Properties',
+ -font => 'Arial 8 bold',
+ -command => \&properties,
+ );
+
+ $frame[0]->Label (
+ -font => 'Arial 10 bold',
+ -text => $TITLE,
+ -anchor => 'center',
+ )->pack;
+
+ $pvobDropdown = createDropdown (
+ $frame[1],
+ 'Project Vob',
+ \$SELECTED{pvob},
+ \&getStreams,
+ \&getPvobs,
+ );
+
+ # Remove the Leave binding from $pvobDropDown
+ $pvobDropdown->bind ('<FocusOut>', undef);
+
+ $streamDropdown = createDropdown (
+ $frame[2],
+ 'Stream',
+ \$SELECTED{stream},
+ \&getBaselines,
+ );
+
+ $streamDropdown->bind ('<FocusIn>', \&setFocus);
+
+ $fromBaselineDropdown = createDropdown (
+ $frame[3],
+ 'From baseline',
+ \$SELECTED{fromBaseline},
+ );
+
+ $fromBaselineDropdown->bind ('<FocusIn>', \&setFocus);
+
+ $toBaselineDropdown = createDropdown (
+ $frame[4],
+ 'To baseline',
+ \$SELECTED{toBaseline},
+ );
+
+ $toBaselineDropdown->bind ('<FocusIn>', \&setFocus);
+
+ $frame[5]->Label (
+ -text => 'Show:',
+ -font => 'Arial 8 bold',
+ )->pack (
+ -side => "left",
+ -padx => 5,
+ -pady => 5,
+ );
+ my $versionsToggle = $frame[5]->Radiobutton (
+ -text => 'Versions',
+ -value => 'versions',
+ -variable => \$MODE,
+ -command => \&::compareBaselines,
+ )->pack (
+ -side => "left",
+ -padx => 5,
+ -pady => 5,
+ );
+ my $activitiesToggle = $frame[5]->Radiobutton (
+ -text => 'Activities',
+ -value => 'activities',
+ -variable => \$MODE,
+ -command => \&::compareBaselines,
+ )->pack (
+ -side => "left",
+ -padx => 5,
+ -pady => 5,
+ );
+
+ # Toggle on activities
+ $activitiesToggle->select;
+
+ $integrationActivitiesCheck = $frame[5]->Checkbutton (
+ -text => 'Integration activities',
+ -variable => \$INTEGRATIONACTIVITIES,
+ -command => \&displayLines,
+ )->pack (
+ -side => "left",
+ -padx => 5,
+ -pady => 5,
+ );
+
+ $output = createList $frame[6];
+
+ $msgWidget = $frame[7]->Label (
+ -font => 'Arial 8 bold',
+ )->pack;
+
+ createButton $frame[8], 'About', \&about;
+ $compareButton = createButton $frame[8], 'Compare', \&::compareBaselines;
+ createButton $frame[8], 'Save', \&saveList;
+ createButton $frame[8], 'Exit', \&exit;
+
+ # Now populate the streams
+ getStreams;
+
+ MainLoop;
+
+ return;
+} # createUI
+
+1;
--- /dev/null
+#!ccperl
+################################################################################
+#
+# File: bin_merge
+# Description: This script will perform a merge checking for any merge
+# conflicts and grouping them at the end. This allows the
+# majority of a large merge to happen and the user can resolve
+# the conflicts at a later time.
+#
+# This script also assists in performing binary merges for the
+# common case. With a binary merge one cannot easily merge the
+# binary code. Most often it's a sitatution where the user will
+# either accept the source or the destination binary file as
+# a whole. In cases where there is only a 2 way merge, this
+# script offers the user the choice to accept 1 binary file
+# or the other or to abort this binary merge. Binary merges
+# conflicts greater than 2 way are not handled.
+#
+# Author: Andrew@DeFaria.com
+# Created: Thu Nov 3 10:55:51 PST 2005
+# Language: Perl
+#
+# (c) Copyright 2005, Andrew@DeFaria.com, all rights reserved
+#
+################################################################################
+use strict;
+use warnings;
+use Getopt::Long;
+use File::Spec;
+
+my $me;
+
+BEGIN {
+ # Set $lib_path
+ my $lib_path = $^O =~ /MSWin/ ? "\\\\brcm-irv\\dfs\\projects\\ccase\\SCM\\lib"
+ : "/projects/ccase/SCM/lib";
+
+ # Extract relative path and basename from script name.
+ $0 =~ /(.*)[\/\\](.*)/;
+
+ my $abs_path = (!defined $1) ? "." : File::Spec->rel2abs ($1);
+ $me = (!defined $2) ? $0 : $2;
+ $me =~ s/\.pl$//;
+
+ # Remove .pl for Perl scripts that have that extension
+ $me =~ s/\.pl$//;
+
+ # Add the appropriate path to our modules to @INC array.
+ unshift @INC, "$abs_path";
+ unshift @INC, $ENV {SITE_PERL_LIBPATH} if defined $ENV {SITE_PERL_LIBPATH};
+ unshift @INC, "$lib_path";
+} # BEGIN
+
+use BinMerge;
+use Display;
+use Logger;
+
+sub Usage {
+ my $msg = shift;
+
+ display "ERROR: $msg\n" if defined $msg;
+
+ display "Usage: $me [-u] [-v] [-d] -branch <branch> -path <path(s)>
+
+Where:
+
+ -u: Display usage
+ -v: Turn on verbose mode
+ -d: Turn on debug mode
+ -branch Branch to merge from
+ -path: Path to consider (Default .)
+";
+ exit 1;
+} # Usage
+
+
+my $branch;
+my $path = ".";
+my $verbose = 0;
+my $debug = 0;
+
+while ($ARGV [0]) {
+ if ($ARGV [0] eq "-v") {
+ $verbose = 1;
+ } elsif ($ARGV [0] eq "-d") {
+ $debug = 1;
+ } elsif ($ARGV [0] eq "-branch") {
+ shift;
+ if (!$ARGV [0]) {
+ Usage "Must specify <branch> after -branch";
+ } else {
+ $branch = $ARGV [0];
+ } # if
+ } elsif ($ARGV [0] eq "-path") {
+ shift;
+ if (!$ARGV [0]) {
+ Usage "Must specify <paths> after -path";
+ } else {
+ $path = join (" ", @ARGV);
+ } # if
+ } elsif ($ARGV [0] eq "-u") {
+ Usage;
+ } else {
+ Usage "Unknown argument found: " . $ARGV [0];
+ } # if
+
+ shift (@ARGV);
+} # while
+
+Usage "Must specify a branch" if !defined $branch;
+
+Merge $branch, $path, $verbose, $debug;
--- /dev/null
+#!ccperl
+################################################################################
+#
+# File: bin_rebase
+# Description: This script will perform a rebase checking for any merge
+# conflicts and grouping them at the end. This allows the
+# majority of a large merge to happen and the user can resolve
+# the conflicts at a later time.
+#
+# This script also assists in performing binary merges for the
+# common case. With a binary merge one cannot easily merge the
+# binary code. Most often it's a sitatution where the user will
+# either accept the source or the destination binary file as
+# a whole. In cases where there is only a 2 way merge, this
+# script offers the user the choice to accept 1 binary file
+# or the other or to abort this binary merge. Binary merges
+# conflicts greater than 2 way are not handled.
+#
+# Author: Andrew@DeFaria.com
+# Created: Thu Nov 3 10:55:51 PST 2005
+# Language: Perl
+#
+# (c) Copyright 2005, Andrew@DeFaria.com, all rights reserved
+#
+################################################################################
+use strict;
+use warnings;
+use Getopt::Long;
+use File::Spec;
+
+my ($me, $SEPARATOR, $NULL);
+
+BEGIN {
+ my ($abs_path, $lib_path);
+
+ # Extract relative path and basename from script name.
+ $0 =~ /(.*)[\/\\](.*)/;
+
+ $abs_path = (!defined $1) ? "." : File::Spec->rel2abs ($1);
+ $me = (!defined $2) ? $0 : $2;
+ $me =~ s/\.pl$//;
+
+ # Remove .pl for Perl scripts that have that extension
+ $me =~ s/\.pl$//;
+
+ # Define the path SEPARATOR
+ $SEPARATOR = ($^O =~ /MSWin/) ? "\\" : "/";
+ $NULL = ($^O =~ /MSWin/) ? "NUL" : "/dev/null";
+
+ # Setup paths
+ $lib_path = "$abs_path" . $SEPARATOR . ".." . $SEPARATOR . "lib";
+
+ # Add the appropriate path to our modules to @INC array.
+ unshift (@INC, "$abs_path");
+ unshift (@INC, "$lib_path");
+} # BEGIN
+
+use BinMerge;
+use Display;
+use Logger;
+
+sub Usage {
+ my $msg = shift;
+
+ display "ERROR: $msg\n" if defined $msg;
+
+ display "Usage: $me [-u] [-v] [-d] -view <viewtag>
+ { -recommended | -baseline <baseline> }
+
+Where:
+
+ -u: Display usage
+ -v: Turn on verbose mode
+ -d: Turn on debug mode
+ -recommended: Rebase from recommended baselines
+ -baseline: Rebase from this baseline
+";
+ exit 1;
+} # Usage
+
+my $baseline;
+my $verbose = 0;
+my $debug = 0;
+
+while ($ARGV [0]) {
+ if ($ARGV [0] eq "-v") {
+ $verbose = 1;
+ } elsif ($ARGV [0] eq "-d") {
+ $debug = 1;
+ } elsif ($ARGV [0] eq "-recommended") {
+ # Nothing to do, leave $baseline undefined
+ } elsif ($ARGV [0] eq "-baseline") {
+ shift;
+ if (!$ARGV [0]) {
+ Usage "Must specify <baseline> after -baseline";
+ } else {
+ $baseline = $ARGV [0];
+ } # if
+ } elsif ($ARGV [0] eq "-u") {
+ Usage;
+ } else {
+ Usage "Unknown argument found: " . $ARGV [0];
+ } # if
+
+ shift (@ARGV);
+} # while
+
+Rebase $baseline, $verbose, $debug;
--- /dev/null
+#!ccperl
+
+=pod
+
+=head1 NAME $RCSfile: diffbl.pl,v $
+
+GUI DiffBL
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.7 $
+
+=item Created:
+
+Mon Oct 25 11:10:47 PDT 2008
+
+=item Modified:
+
+$Date: 2011/08/31 21:57:06 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage cqperl diffbl.pl: [-u|sage] [-v|erbose] [-d|ebug]
+ [-[baseline1|bl1] <bl1>]
+ [-[baseline2|bl2] <bl2>]
+ [-p|vob <pvob>]
+
+ Where:
+ -u|sage: Displays usage
+ -ve|rbose: Be verbose
+ -d|ebug: Output debug messages
+ -bl1 <bl1> Full baseline 1 to use in the comparison
+ -bl2 <bl2> Full baseline 2 to use in the comparison
+ -p|vob <pvob> Pvob to use
+
+=head2 DESCRIPTION
+
+This script provides a Perl/Tk GUI application to compare baselines. It provides
+several benefits over IBM/Rational's graphical diffbl (cleartool diffbl -g ...).
+First, it assists you in finding baselines to compare whereas diffbl -g requires
+that you find the baselines yourself. When diffbl.pl is run you are presented
+with a GUI that you can use to find baselines by either using the dropdown to
+select pvobs, streams and ultimately baselines. You can also simply type part
+the name and diffbl.pl will narrow down the list of pvobs, streams or baselines
+in the drop down. This allows you to easily find the baselines you wish to
+compare.
+
+Additionally, IBM/Rational's diffbl -g -version often shows extremely long, but
+technically accurate version extended pathnames where the user thinks more along
+the lines of "path to element in a vob" only. diffbl.pl shows shorter, more
+easily comprehenable pathnames. diffbl.pl also shows only the latest version of
+the element. Thus if foo.c changed with version 3, 4 and 5 then you see just
+foo.c and it represents foo.c version 5.
+
+Finally, diffbl.pl provides a way to save the list of elements that have changed
+in a file.
+
+diffbl.pl also provides right click menu options to easily show the elements
+properties, compare to previous, show the version tree and history of the
+element.
+
+=cut
+
+use strict;
+use warnings;
+
+use FindBin;
+use Cwd;
+use Getopt::Long;
+
+use lib "$FindBin::Bin/../CCDB/lib", "$FindBin::Bin/../lib";
+
+use DiffBLUI;
+use Display;
+use Utils;
+use OSDep;
+
+use Clearcase;
+use Clearcase::View;
+
+$DiffBLUI::SELECTED{pvob} = $ENV{pvob}
+ ? Clearcase::vobname ($ENV{pvob})
+ : '8800_projects';
+
+our $view;
+my $currentStream;
+
+my ($bl1, $bl2);
+
+END {
+ $view->remove
+ if $view;
+} # END
+
+# Should this be moved to Clearcase.pm?
+sub ccerror ($$@) {
+ my ($msg, $status, @output) = @_;
+
+ Tkerror join ("\n", "$msg (Status: $status)", "\n", @output);
+
+ exit $status;
+} # ccerror
+
+sub mkview () {
+ my $user = $ARCH eq 'windows' ? $ENV{USERNAME} : $ENV{USER};
+
+ my $viewname = "${user}_$FindBin::Script";
+
+ Tkmsg "Creating a view to work in", -1;
+
+ my $newView = Clearcase::View->new ($viewname);
+
+ # If the streams have changed then we need to recreate the view.
+ $currentStream ||= $DiffBLUI::SELECTED{stream};
+
+ if ($currentStream ne $DiffBLUI::SELECTED{stream}) {
+ $newView->remove;
+ $currentStream = $DiffBLUI::SELECTED{stream};
+ } # if
+
+ # The create method needs to support additional parameters such as -stream so
+ # we have to do this by hand right now...
+ my ($status, @output) =
+ $Clearcase::CC->execute (
+ "mkview -tag $viewname -stream $DiffBLUI::SELECTED{stream}\@" .
+ "$Clearcase::VOBTAG_PREFIX$DiffBLUI::SELECTED{pvob} -stgloc -auto"
+ );
+
+ unless (grep {/already exists/} @output) {
+ if ($status) {
+ ccerror ("Unable to create view $viewname", $status, @output);
+ } # if
+ } # unless
+
+ $newView->updateViewInfo;
+
+ # Start the view
+ ($status, @output) = $newView->start;
+
+ ccerror ('Unable startview ' . $newView->tag, $status, @output)
+ if $status;
+
+ Tkmsg 'Done';
+
+ return $newView;
+} # mkview
+
+sub compareBaselines () {
+ unless ($DiffBLUI::SELECTED{pvob}) {
+ Tkerror 'Project Vob must be selected';
+ return;
+ } # unless
+
+ unless ($DiffBLUI::SELECTED{fromBaseline}) {
+ Tkerror 'From baseline must be selected';
+ return;
+ } # unless
+
+ unless ($DiffBLUI::SELECTED{toBaseline}) {
+ Tkerror 'To baseline must be selected';
+ return;
+ } # unless
+
+ DiffBLUI::busy;
+
+ if ($DiffBLUI::MODE eq 'versions') {
+ $DiffBLUI::integrationActivitiesCheck->configure (-state => 'disable');
+ } else {
+ $DiffBLUI::integrationActivitiesCheck->configure (-state => 'normal');
+ }
+
+ # Create a view to work in.
+ $view = mkview;
+
+ # Get into the view context
+ my $view_context = $Clearcase::VIEWTAG_PREFIX . '/' . $view->tag;
+ my $cwd = getcwd;
+
+ # For my Cygwin environment - translate that path back into a Windows path
+ if ($ARCH eq 'cygwin') {
+ my @cwd = `cygpath -w $cwd`;
+ chomp @cwd;
+
+ $cwd = $cwd[0];
+ } # if
+
+ my ($status, @output) = $Clearcase::CC->execute ("cd \"$view_context\"");
+
+ ccerror "Unable to set view context to $view_context", $status, @output
+ if $status;
+
+ Tkmsg 'Comparing baselines (This may take a while)', -1;
+
+ %DiffBLUI::LINES= ();
+
+ my $cmd = "diffbl -$DiffBLUI::MODE ";
+ $cmd .= $DiffBLUI::SELECTED{fromBaseline};
+ $cmd .= "\@$Clearcase::VOBTAG_PREFIX$DiffBLUI::SELECTED{pvob} ";
+ $cmd .= $DiffBLUI::SELECTED{toBaseline};
+ $cmd .= "\@$Clearcase::VOBTAG_PREFIX$DiffBLUI::SELECTED{pvob}";
+
+ ($status, @output) = $Clearcase::CC->execute ($cmd);
+
+ ccerror "Unable to perform command $cmd", $status, @output
+ if $status;
+
+ Tkmsg 'Done';
+
+ my $viewtag = $Clearcase::VIEWTAG_PREFIX . '/' . $view->tag;
+
+ foreach (@output) {
+ # Skip lines that don't have either <<, >>, <- or -> at the beginning
+ next unless /^(\<\-|\>\>|\<\<|\-\>)\s/;
+
+ if ($DiffBLUI::MODE eq 'activities') {
+ if (/\W+\s+(.*)\@/) {
+ $DiffBLUI::LINES{$1} = $1;
+ } # if
+ } else {
+ # Change those silly '\'s -> '/'s
+ s/\\/\//g;
+
+ # Extract the pathname and strip off the version. Note we use a hash here
+ # to get uniqueness based on the element name and only store the last
+ # version checked in. It is very possible, for example, that there is foo
+ # versions 1, 2 and 3 but we want to more simply just report that foo
+ # changed - not that foo changed 3 times.
+ if (/\W+\s+(.*)$Clearcase::SFX/) {
+ my $elementName = $1;
+
+ # Remove view path and tagname from $elementName
+ $elementName =~ s/$viewtag//;
+
+ $DiffBLUI::LINES{$elementName} = $elementName;
+ } # if
+ } # if
+ } # foreach
+
+ ($status, @output) = $Clearcase::CC->execute ("cd \"$cwd\"");
+
+ ccerror "Unable to set view context to $cwd", $status, @output
+ if $status;
+
+ displayLines;
+
+ DiffBLUI::unbusy;
+
+ Tkmsg 'Done', 1;
+
+ return;
+} # compareBaselines
+
+# Main
+GetOptions (
+ 'usage' => sub { Usage },
+ 'verbose' => sub { set_verbose },
+ 'debug' => sub { set_debug },
+ 'baseline1|bl1=s' => \$bl1,
+ 'baseline2|bl2=s' => \$bl2,
+ 'pvob=s' => \$DiffBLUI::SELECTED{pvob},
+) or Usage "Invalid parameter";
+
+createUI;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<Cwd>
+
+L<FindBin>
+
+L<Getopt::Long|Getopt::Long>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ Clearcase
+ Clearcase::View
+ DiffBLUI
+ Display
+ OSDep
+ Utils
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Clearcase.pm">Clearcase</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Clearcase/View.pm">Clearcase::View</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=cc/DiffBLUI.pm">DiffBLUI</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/OSDep.pm">OSDep</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Utils.pm">Utils</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this script
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2010, ClearSCM, Inc. All rights reserved.
+
+=cut
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: dominos,v
+# Revision: 1.1.1.1
+# Description: Quick script to deliver a stream to an integration view
+# (Hot and fresh in 30 minutes or less! :-)
+# Author: Andrew@DeFaria.com
+# Created: Mon Feb 13 10:35:34 PST 2006
+# Modified: 2007/05/17 07:45:48
+# Language: Perl
+#
+# (c) Copyright 2006, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/../lib";
+
+use Getopt::Long;
+
+use Clearcase;
+use Clearcase::View;
+use DateUtils;
+use Display;
+use OSDep;
+use Logger;
+
+my $me = $FindBin::Script;
+my $pvob = $Clearcase::vobtag_prefix . "ilm_pvob";
+my $logdir = $ENV {TMP} ? $ENV {TMP} : ".";
+my $log = Logger->new (
+ path => $logdir,
+ name => $me,
+);
+
+my $from_address = "build\@persistcorp.com";
+my $to_addresses = "philippe.rollet\@hp.com,andrew.defaria\@hp.com";
+
+sub Usage {
+ my $msg = shift;
+
+ display "ERROR: $msg\n" if defined $msg;
+
+ display "Usage: $me\t[-u] [-v] [-d] [-stream <stream>] [-view_tag <view_tag>]
+
+Where:
+
+ -usage: Display usage
+ -vebose: Turn on verbose mode
+ -debug: Turn on debug mode
+ -stream: Name of stream to deliver from
+ -view_tag: View tag to deliver to
+";
+ exit 1;
+} # Usage
+
+sub CheckForFailures {
+ my $log = shift;
+
+ my @lines = $log->loglines;
+
+ my @failures;
+ my $element;
+ my $from;
+ my $branch;
+
+ foreach (@lines) {
+ if (/Needs Merge "(.*)".*from (.*) base/) {
+ $element = $1;
+ $from = $2;
+
+ if ($arch eq "windows" or $arch eq "cygwin") {
+ if ($from =~ /.*\\(\w*)\\\d*/) {
+ $branch = $1;
+ } # if
+ } else {
+ if ($from =~ /.*\/(\w*)\/\d*/) {
+ $branch = $1;
+ } # if
+ } # if
+ } elsif (/merge: Error: \*\*\* Aborting\.\.\./ or
+ /\*\*\* No Automatic Decision Possible/) {
+ # Argh! On Windows silly \'s are used and it always interferes
+ # with things. Even though $element has the requesite doubling
+ # of the \'s, one gets eaten up by calling system, the
+ # eventually cleartool call here. So we change them from \ -> /!
+ $element =~ tr /\\/\// if ($arch eq "windows" or $arch eq "cygwin");
+ my ($status, @output) = Clearcase::cleartool (
+ "lshistory -last -directory -branch $branch -fmt \"%Fu %u\" " . $element
+ );
+
+ # Argh, sometimes %Fu above gives only a one name fullname
+ # (e.g. Bounour). Not only do we need to account for this but we
+ # have to abandon the hope of composing an email address!
+ $_ = $output [0];
+ my @line = split;
+ my ($name, $email, $username);
+
+ if (scalar @line eq 3) {
+ $name = $line [0] . " " . $line [1];
+ $email = $line [0] . "." . $line [1] . "\@hp.com";
+ $username = $line [2];
+ $element .= " \"$name\" <$email> ($username)";
+ } elsif (scalar @line eq 2) {
+ $name = $line [0];
+ $username = $line [1];
+ $element .= " \"$name\" ($username)";
+ } # if
+
+ push @failures, $element;
+ } # if
+ } # foreach
+
+ return @failures;
+} # CheckForFailures
+
+sub Deliver {
+ my $stream = shift;
+ my $view_tag = shift;
+ my $log = shift;
+
+ $log->msg ("Delivering $stream -> $view_tag");
+
+ # Here we do the actual delivery. Note we use all of -force, -abort
+ # and -complete. The force option says "Don't prompt me - just do
+ # it!". The abort says abort this delivery if we cannot do it in an
+ # automated fashion. The complete options says "If you can
+ # successfully merge then complete the delivery".
+ my ($status, @output) = Clearcase::cleartool (
+ "deliver -force -abort -complete -stream $stream\@\\$pvob -to $view_tag 2>&1",
+ $true
+ );
+
+ foreach (@output) {
+ $log->msg ($_);
+ } # foreach
+
+ if ($status ne 0) {
+ $log->msg ("Unable to deliver from $stream -> $view_tag");
+ return $false;
+ } else {
+ $log->msg ("Delivery from $stream stream to $view_tag view successful");
+ return $true;
+ } # if
+} # Delivery
+
+# Get options
+my $stream;
+my $view_tag;
+my $result = GetOptions ("debug" => sub { set_debug },
+ "usage" => sub { Usage },
+ "verbose" => sub { set_verbose },
+ "stream=s" => \$stream,
+ "view_tag=s" => \$view_tag,
+ );
+
+Usage "Stream must be specified" if !defined $stream;
+Usage "View tag must be specified" if !defined $view_tag;
+
+my $view = new Clearcase::View (tag => $view_tag);
+
+Usage "View tag $view_tag is not a valid view" if !defined $view;
+
+# Should put in code to validate that the stream is a valid Clearcase object.
+
+my $status = Deliver $stream, $view_tag, $log;
+my $subject = "Delivery from $stream -> $view_tag ";
+$subject .= $status eq $true ? "succeeded"
+ : "failed";
+my $heading = "<h3>Delivery from $stream -> $view_tag ";
+$heading .= $status eq $true ? "<font color=green>succeeded</font>"
+ : "<font color=red>failed</font>";
+$heading .= "</h3>";
+
+my %additional_emails;
+
+if ($status ne $true) {
+ my @failures = CheckForFailures ($log);
+
+ if (scalar @failures gt 0) {
+ $heading .= "\n<p>The following elements could not be automatically merged:</p>";
+ $heading .= "\n<ol>\n";
+
+ foreach (@failures) {
+ if (/<(.*)>.*\((\w*)\)/) {
+ $additional_emails {$2} = $1;
+ } # if
+ $heading .= "<li>$_</li>\n";
+ } # foreach
+ $heading .= "</ol>\n";
+ } # if
+} # if
+
+$log->maillog (
+ from => $from_address,
+ to => $to_addresses,
+ cc => (join ",", values (%additional_emails)),
+ mode => "html",
+ subject => YMD . ": " . $subject,
+ heading => $heading,
+ footing => "-- \n<br>Regards,<br>\n<i>Release Engineering</i>",
+);
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: etf.pl,v $
+
+Evil Twin Finder
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision:
+
+$Revision: 1.5 $
+
+=item Created:
+
+Fri Apr 23 09:40:31 PDT 2010
+
+=item Modified:
+
+$Date: 2011/01/09 01:00:28 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage: eft.pl [-u|sage] [-ve|rbose] [-d|ebug] [-di|rectory <dir>]
+
+ Where:
+
+ -u|sage: Displays usage
+ -ve|rbose: Be verbose
+ -d|ebug: Output debug messages
+
+ -dir Directory to process
+
+=head1 DESCRIPTION
+
+This script will search for existing evil twins in a Clearcase vob. It is
+intended to be used in the context of a base Clearcase view with a default
+config spec.
+
+An evil twin is defined as two or more Clearcase elements that share the same
+path, and same name, but have different OIDs thus having different version
+histories. This can occur when a user creates an element in a directory that
+used to exist in this same directory on another branch or on a previous version
+of the same branch. By default Clearcase will create an element with a new OID.
+This new, evil twin will then develop it's own version history. This then
+becomes a problem when you attempt to merge branches - which twin (OID) should
+Clearcase keep track of?
+
+Most Clearcase users implement an evil twin trigger to prevent the creation of
+evil twins but sometimes evil twins have already been created. This script helps
+identify these already existing evil twins.
+
+Note: Evil twins can also happen if you only apply your evil twin trigger to the
+mkelem Clearcase action. It should be applied to the lnname action as elements
+come into creation by things like the cleartool ln, mv and mkdir commands. These
+all eventually do an lnname so that's where you should put your evil twin
+trigger.
+
+=head1 ALGORITHM
+
+ TODO: Is cleartool find really needed? I mean since we are going through
+ the extended version namespace don't we by default find all
+ subdirectories?
+
+This script will use cleartool find to process all directory elements from
+$startingDir (Default '.'). For each version of the directory a hash will be
+built up containing all of the element names in that directory version.
+Elements are always added and never deleted in this hash as we are looking for
+all elements that have ever existed in the directory at any point in time.
+
+This script then dives into the view extended namespace for directory elements
+examining the internal Clearcase structures. If we find a branch we recurse or
+numbered directory version we recurse looking for file elements (TODO: What
+about directory evil twins?). Note that we skip version 0 as version 0 is never
+interesting - it is always a duplicate of what it branched from and empty.
+
+Directory versions that are not numbered are labels or baselines that point to
+numbered directory versions so we don't need to look at them again.
+
+For each file element we find we use the cleartool dump command to get the OID
+of this particiular versioned element and build up an array of hashes of all the
+elements in the directory. For each element version we maintain a hash keyed by
+the OID. The structure also contains a count of the number of times the OID was
+found. An evil twin therefore will have multiple OIDs for the same element
+version name.
+
+After the directory is processed we look though the array of hashes for elements
+that have multiple OIDs and report them. Then we proceed to the next directory.
+
+=cut
+
+use strict;
+use warnings;
+
+use Getopt::Long;
+use File::Basename;
+use Cwd;
+
+use FindBin;
+use lib "$FindBin::Bin/../lib";
+
+use Clearcase;
+use Clearcase::Element;
+use Display;
+use Logger;
+use TimeUtils;
+use Utils;
+
+my $VERSION = '1.0';
+
+my (%total, %dirInfo, $log, $startTime);
+
+=pod
+
+=head2 reportDir (%directoryInfo)
+
+Report any evil twins found in %directoryInfo
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item %directoryInfo
+
+Structure representing the OIDs of element in a direcotry
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item nothing
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+sub reportDir (%) {
+ my (%directoryInfo) = @_;
+
+ my $ets = 0;
+
+ foreach my $filename (sort keys %directoryInfo) {
+ my @oids = @{$directoryInfo{$filename}};
+
+ if (scalar @oids > 1) {
+ $ets++;
+
+ $log->msg ("File: $filename");
+
+ foreach (@oids) {
+ $log->msg ("\tOID: $$_{OID} ($$_{count})");
+ $log->msg ("\tFirst detected \@: $$_{version}");
+ } # foreach
+ } # if
+ } # foreach
+
+ return $ets;
+} # reportDir
+
+=pod
+
+=head2 proceedDir $dirName
+
+Build up a data structure for $dirName looking for evil twins
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $dirName
+
+Directory to examine
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item %dirInfo
+
+Directory info hash keyed by element name whose value is an array of oidInfo
+hashes containing a unique OID and a count of how many occurences of that OID
+exist for that element.
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+sub processDir ($);
+sub processDir ($) {
+ my ($dirName) = @_;
+
+ opendir my $dir, $dirName
+ or $log->err ("Unable to open directory $dirName - $!", 1);
+
+ my @dirVersions = grep {!/^\./} readdir $dir;
+
+ closedir $dir;
+
+ my ($directory, $version) = split /$Clearcase::SFX/, $dirName;
+
+ $directory = basename (cwd)
+ if $directory eq '.';
+
+ my $displayName = "$directory$Clearcase::SFX$version";
+
+ # We only want to deal with branches and numbered versions. Non-numbered
+ # versions which are not branches represent labels and baselines which are
+ # just aliases for directory and file elements. Branches represent recursion
+ # points and numbered versions represent unique directory versions.
+ my @elements;
+
+ foreach (@dirVersions) {
+ my ($status, @output) = $Clearcase::CC->execute (
+ "describe -fmt %m $dirName/$_"
+ );
+ my $objkind = $output[0];
+
+ if ($objkind =~ / element/) {
+ push @elements, $_;
+ } elsif (/^\d/ or $objkind eq 'branch') {
+ # Skip 0 element - it's never interesting.
+ next if $_ eq '0';
+
+ # Recurse for branches and numbered directory versions
+ if ($objkind eq 'branch') {
+ $total{branches}++;
+ } else {
+ $total{'directory versions'}++;
+ } # if
+
+ verbose_nolf '.';
+
+ #$log->log ("Recurse:\t$displayName/$_");
+
+ %dirInfo = processDir "$dirName/$_";
+
+ next;
+ } # if
+ } # foreach
+
+ foreach (@elements) {
+ $total{'element versions'}++;
+
+ #$log->log ("Element:\t$displayName/$_");
+
+ # Get oid using the helper function
+ my $oid = Clearcase::Element::oid "$dirName/$_";
+
+ if ($dirInfo{$_}) {
+ my $found = 0;
+
+ # Search our %dirInfo for a version matching $version
+ foreach (@{$dirInfo{$_}}) {
+ # Increment count if we find a matching oid
+ if ($$_{OID} eq $oid) {
+ $$_{count}++;
+ $found = 1;
+ last;
+ } # if
+ } # foreach
+
+ unless ($found) {
+ # If we didn't find a match then make a new %objInfo starting with a
+ # count of 1. Also save this current $version, which is the first
+ # instance of this new oid.
+ push @{$dirInfo{$_}}, {
+ OID => $oid,
+ count => 1,
+ version => "$dirName/$_",
+ };
+ } # unless
+ } else {
+ $dirInfo{$_} = [{
+ OID => $oid,
+ count => 1,
+ version => "$dirName/$_",
+ }];
+ } # if
+ } # foreach
+
+ return %dirInfo;
+} # processDir
+
+=pod
+
+=head2 proceedDirs $startingDir
+
+Process all directories under $startingDir
+
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $startingDir
+
+Directory to start processing
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $total{etf}
+
+Total number of evil twins found
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+sub processDirs ($) {
+ my ($startingDir) = @_;
+
+ my $cmd = "cleartool find \"$startingDir\" -type d -print";
+
+ open my $dirs, '-|', $cmd
+ or $log->err ("Unable to execute $cmd - $!", 1);
+
+ while (<$dirs>) {
+ chomp; chop if /\r$/;
+
+ my $displayName = $_;
+
+ $displayName =~ s/\@\@$//;
+
+ if ($displayName eq '.') {
+ $displayName = basename (cwd);
+ } # if
+
+ $log->msg ("Processing $displayName");
+
+ my $startingTime = time;
+ my %directoryInfo = processDir $_;
+
+ verbose '';
+
+ display_duration $startingTime, $log;
+
+ $total{'evil twins'} += reportDir %dirInfo;
+ } # while
+
+ close $dirs
+ or $log->err ("Unable to close $cmd - $!");
+
+ return $total{'evil twins'};
+} # processDirs
+
+# Main
+local $| = 1;
+
+my $startingDir = '.';
+
+GetOptions (
+ usage => sub { Usage },
+ verbose => sub { set_verbose },
+ debug => sub { set_debug },
+ 'directory=s' => \$startingDir,
+) or Usage 'Invalid parameter';
+
+$startTime = time;
+
+$log = Logger->new;
+
+$log->msg ("Evil Twin Finder $FindBin::Script v$VERSION");
+
+processDirs $startingDir;
+
+Stats \%total, $log;
+
+$log->msg ("$FindBin::Script finished @ " . localtime);
+
+display_duration $startTime, $log;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<Cwd>
+
+L<File::Basename|File::Basename>
+
+L<FindBin>
+
+L<Getopt::Long|Getopt::Long>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ Clearcase
+ Clearcase::Element
+ Display
+ Logger
+ TimeUtils
+ Utils
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Clearcase.pm">Clearcase</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Clearcase/Element.pm">Element</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Logger.pm">Logger</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/TimeUtils.pm">TimeUtils</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Utils.pm">Utils</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this script
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2010, ClearSCM, Inc. All rights reserved.
+
+=cut
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: findview,v
+# Revision: 1.1.1.1
+# Description: This script will locate a view by searching through the various
+# regions.
+# Author: Andrew@DeFaria.com
+# Created: Mon May 3 09:06:55 PDT 2004
+# Modified: 2007/05/17 07:45:48
+# Language: Perl
+#
+# (c) Copyright 2004, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/../lib";
+
+use Display;
+
+sub Usage {
+ display "Usage $FindBin::Script: [ <view tag>... | -u ]";
+ display "\nWhere:";
+ display "\t<view tag>\tName of the view to find (can be partial name)";
+
+ exit 1;
+} # Usage
+
+sub SearchRegions {
+ my $view = shift;
+
+ my $nbr_views = 0;
+
+ # Get a list of regions
+ my @regions = `cleartool lsregion`;
+ my $region;
+
+ # Process each region
+ foreach $region (@regions) {
+ chomp $region;
+ chop $region if $region =~ /\r/; # Remove carriage returns
+
+ verbose "Searching $region region...\n";
+
+ # Get a list of views in the region
+ my @lines = `cleartool lsview -region $region`;
+
+ # Parse the lines extracting view tag and storage area
+ foreach (@lines) {
+ verbose "Searching view $_";
+ if (/[\* ]\s*(\S*)\s*\S*/) {
+ my $name = $1;
+
+ if ($name =~ /$view/i) {
+ display "\t$name ($region)";
+ $nbr_views++;
+ next;
+ } # if
+ } # if
+ } # foreach @lines
+ } # foreach @regions
+
+ return $nbr_views;
+} # SearchRegions
+
+# Get parms
+if (defined $ARGV [0] and $ARGV [0] =~ /^-u/) {
+ Usage;
+} # if
+
+foreach (@ARGV) {
+ verbose "Searching for views containing \"$_\"";
+ my $nbr_views = SearchRegions $_;
+
+ if ($nbr_views eq 0) {
+ display "No views found"
+ } elsif ($nbr_views eq 1) {
+ display "1 view found";
+ } else {
+ display "$nbr_views views found";
+ } # if
+
+ verbose " matching \"$_\"";
+} # foreach
+
+# All done...
+exit 0;
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: findvob,v
+# Revision: 1.1.1.1
+# Description: This script will locate a vob by searching through the various
+# regions.
+# Author: Andrew@DeFaria.com
+# Created: Mon May 3 09:06:55 PDT 2004
+# Modified: 2007/05/17 07:45:48
+# Language: Perl
+#
+# (c) Copyright 2004, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/../lib";
+
+use Display;
+
+sub Usage {
+ display "Usage $FindBin::Script: [ <vob tag>... | -u ]";
+ display "\nWhere:";
+ display "\t<vob tag>\tName of the vob to find (can be partial name)";
+
+ exit 1;
+} # Usage
+
+sub SearchRegions {
+ my $vob = shift;
+
+ my $nbr_vobs = 0;
+
+ # Get a list of regions
+ my @regions = `cleartool lsregion`;
+ my $region;
+
+ # Process each region
+ foreach $region (@regions) {
+ chomp $region;
+ chop $region if $region =~ /\r/; # Remove carriage returns
+
+ # Get a list of vovs in the region
+ my @lines = `cleartool lsvob -region $region`;
+
+ # Parse the lines extracting vob tag and storage area
+ foreach (@lines) {
+ if (/[\* ]\s*(\S*)\s*\S*/) {
+ my $name = $1;
+
+ if ($name =~ /$vob/i) {
+ display "\t$name ($region)";
+ $nbr_vobs++;
+ next;
+ } # if
+ } # if
+ } # foreach @lines
+ } # foreach @regions
+
+ return $nbr_vobs;
+} # SearchRegions
+
+# Get parms
+if (defined $ARGV [0] and $ARGV [0] =~ /^-u/) {
+ Usage;
+} # if
+
+foreach (@ARGV) {
+ verbose "Searching for vobs containing \"$_\"\n";
+ my $nbr_vobs = SearchRegions $_;
+
+ if ($nbr_vobs eq 0) {
+ display "No vobs found"
+ } elsif ($nbr_vobs eq 1) {
+ display "1 vob found";
+ } else {
+ display "$nbr_vobs vobs found";
+ } # if
+
+ verbose " matching \"$_\"\n";
+} # foreach
+
+# All done...
+exit 0;
+
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: lockvobs,v
+# Revision: 1.1.1.1
+# Description: [Un]locks all vobs in the current region, reports results
+# Author: Andrew@DeFaria.com
+# Created: Mon Mar 15 08:48:24 PST 2004
+# Modified: 2007/05/17 07:45:48
+# Language: Perl
+#
+# (c) Copyright 2004, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+use strict;
+use warnings;
+
+use Net::SMTP;
+use File::Spec;
+
+# This will be set in the BEGIN block but by putting them here the become
+# available for the whole script.
+my (
+ $abs_path,
+ $me,
+ $bin_path,
+ $triggers_path,
+ $lib_path,
+ $log_path,
+ $etc_path,
+ $windows
+);
+
+BEGIN {
+ # Extract relative path and basename from script name.
+ $0 =~ /(.*)[\/\\](.*)/;
+
+ $abs_path = (!defined $1) ? "." : File::Spec->rel2abs ($1);
+ $me = (!defined $2) ? $0 : $2;
+
+ # Check to see if we are running on Windows
+ $windows = ($^O =~ /MSWin/) ? "yes" : "no";
+
+ # Setup paths
+ $bin_path = "$abs_path";
+ $triggers_path = "$abs_path/../triggers";
+ $lib_path = "$abs_path/../lib";
+ $log_path = "$abs_path/../log";
+ $etc_path = "$abs_path/../etc";
+
+ # Add the appropriate path to our modules to @INC array.
+ unshift (@INC, "$lib_path");
+} # BEGIN
+
+use Display;
+
+# Store logfile in CM_TOOLS/logs
+my $logfile = "$log_path/lockvobs.log";
+
+# Production vob server
+my $vob_server = defined $ENV {VOBSERVER} ? $ENV {VOBSERVER} : undef;
+
+# Gotta be from somebody!
+my $from = defined $ENV {FROM} ? $ENV {FROM} : undef;
+
+# This should be changed to an email alias
+my @to = ();
+
+# Who gets notified when there are errors
+my @errors_to = ();
+
+my $unlock = "no";
+my $execute = "yes";
+my $smtphost = "appsmtp";
+
+# Exceptions file
+my $exceptions_file = "$etc_path/vob_exceptions";
+
+# Any errors?
+my $errors = 0;
+
+sub Usage {
+ my $me = $0;
+
+ $me =~ s/\.\///;
+
+ print "Usage $me:\t[-u] [-n] [-smtphost <smtphost>] [-to <email addresses]\n";
+ print "\t\t[-errors-to <email addresses>]\n";
+ print "\nWhere:\n";
+ print "\t-u\t\tUnlock vobs (default lock vobs)\n";
+ print "\t-smtphost\tSpecifies what SMTP host to use for mail (default\n";
+ print "\t\t\tnotesmail01)\n";
+ print "\t-to\t\tComma separated list (no spaces) of email addresses to\n";
+ print "\t\t\tsend output to (default: bsomisetty\@ameriquest.net,\n";
+ print "\t\t\tsgopavarapu\@ameriquest.net)\n";
+ print "\t-errors-to\tComma separated list (no spaces) of email addresses\n";
+ print "\t\t\tto send (only errors) to (default:\n";
+ print "\t\t\tadefaria\@ameriquest.net)\n";
+ exit 1;
+} # Usage
+
+sub logmsg {
+ my $msg = shift;
+
+ open LOGFILE, ">>$logfile"
+ or die "Unable to open logfile: $logfile - $!";
+
+ print LOGFILE $msg . "\n";
+
+ close LOGFILE;
+} # logmsg
+
+sub notify {
+ my $smtphost = shift;
+ my $from = shift;
+ my $errors = shift;
+ my $unlock = shift;
+
+ my $subject = $unlock eq "yes" ? "Unlock VOBs" : "Lock VOBs";
+
+ # Connect to mail server
+ my $smtp = Net::SMTP->new ($smtphost);
+
+ die "Unable to open connection to mail host: $smtphost\n" if !defined $smtp;
+
+ # Compose message
+ $smtp->mail ($from);
+
+ if ($errors ne 0) {
+ # Add @errors_to
+ foreach (@errors_to) {
+ push @to, $_;
+ } # foreach
+ } # if
+
+ # Add @to
+ foreach (@to) {
+ $smtp->to ($_);
+ } # foreach
+
+ # Start email data
+ $smtp->data ();
+
+ # Add From line
+ $smtp->datasend ("From: $from\n");
+
+ # Add @to and @errors_to
+ $smtp->datasend ("To: " . join (",", @to) . "\n");
+
+ # Add subject
+ $smtp->datasend ("Subject: $subject\n\n");
+
+ # Open logfile
+ open LOGFILE, $logfile
+ or die "Unable to open logfile $logfile - $!\n";
+
+ while (<LOGFILE>) {
+ $smtp->datasend ($_);
+ } # while
+
+ $smtp->dataend ();
+ $smtp->quit;
+
+ return 0;
+} # notify
+
+sub Error {
+ my $msg = shift;
+
+ logmsg $msg;
+
+ $errors++;
+
+ notify $smtphost, $from, $errors, $unlock;
+
+ exit $errors;
+} # Error
+
+sub IsAMember {
+ my $item = shift;
+ my @list = @_;
+
+ $item =~ s/\\//g;
+
+ foreach (@list) {
+ chomp;
+ s/\\//g;
+ return 1 if $item eq $_;
+ } # foreach
+
+ return 0;
+} # IsAMember
+
+# Get parms
+while ($#ARGV >= 0) {
+ if ($ARGV [0] eq "-u") {
+ $unlock = "yes";
+ shift;
+ next;
+ } # if
+
+ if ($ARGV [0] eq "-n") {
+ $execute = "no";
+ shift;
+ next;
+ } # if
+
+ if ($ARGV [0] eq "-smtphost") {
+ shift;
+ $smtphost = $ARGV [0];
+ shift;
+ next;
+ } # if
+
+ if ($ARGV [0] eq "-to") {
+ shift;
+ @to = split /,/,$ARGV [0];
+ shift;
+ next;
+ } # if
+
+ if ($ARGV [0] eq "-errors-to") {
+ shift;
+ @errors_to = split /,/,$ARGV [0];
+ shift;
+ next;
+ } # if
+
+ Usage;
+} # while
+
+Usage "Vob server hasn't been defined" if !defined $vob_server;
+Usage "From has not been specified" if !defined $from;
+Usage "To has not been specified" if @to;
+Usage "Errors to has not been specififed" if @errors_to;
+
+open EXCEPTIONS, $exceptions_file
+ or error "Unable to open exceptions file ($exceptions_file)", 1;
+
+my @exceptions = <EXCEPTIONS>;
+
+# Remove logfile if present
+unlink ($logfile) if (-e $logfile);
+
+# Get list of vobs
+open (VOBS, "cleartool lsvob -short -host $vob_server|")
+ or Error "Can't list vobs: $!";
+
+# Process them
+while (<VOBS>) {
+ chomp;
+ chop if /\r/; # any carriage return
+
+ next if $#exceptions ne 0 and IsAMember ($_, @exceptions);
+
+ $_ = "\\" . $_ if $windows ne "yes";
+
+ # [Un]lock the vob
+ if ($unlock eq "yes") {
+ if ($execute eq "no") {
+ print "[noexecute] cleartool unlock vob:$_\n";
+ } else {
+ system ("cleartool unlock vob:$_ >> $logfile 2>&1");
+ } # if
+ } else {
+ if ($execute eq "no") {
+ print "[noexecute] cleartool lock vob:$_\n";
+ } else {
+ system ("cleartool lock vob:$_ >> $logfile 2>&1");
+ } # if
+ } # if
+
+ # Convert the status
+ my $status = $? >> 8;
+
+ if ($status ne 0) {
+ $errors++;
+ } # if
+} # while
+
+my $status = $execute eq "yes" ? notify $smtphost, $from, $errors, $unlock : 0;
+
+exit $status;
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: log_activity,v
+# Revision: 1.1.1.1
+# Description: Logs Clearcase activity
+# Author: Andrew@DeFaria.com
+# Created: Tue Dec 27 16:33:30 PST 2005
+# Modified: 2007/05/17 07:45:48
+# Language: perl
+#
+# (c) Copyright 2000-2005, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+use strict;
+use warnings;
+use File::Spec;
+
+my $me;
+
+BEGIN {
+ # Set $lib_path
+ my $lib_path = $^O =~ /MSWin/ ? "\\\\brcm-irv\\dfs\\projects\\ccase\\SCM\\lib"
+ : "/projects/ccase/SCM/lib";
+
+ # Extract relative path and basename from script name.
+ $0 =~ /(.*)[\/\\](.*)/;
+
+ my $abs_path = (!defined $1) ? "." : File::Spec->rel2abs ($1);
+ $me = (!defined $2) ? $0 : $2;
+ $me =~ s/\.pl$//;
+
+ # Add the appropriate path to our modules to @INC array.
+ unshift @INC, "$lib_path";
+ unshift @INC, $ENV {SITE_PERL_LIBPATH} if defined $ENV {SITE_PERL_LIBPATH};
+ unshift @INC, "$abs_path";
+} # BEGIN
+
+use OSDep;
+use Display;
+use DateUtils;
+use Logger;
+use Clearcase;
+use Clearcase::Vobs;
+use Clearcase::View;
+
+# The lshistory command needs a view context. We'll create this view
+# if necessary.
+my $tag = $ENV {DEFAULT_VIEW} ? $ENV {DEFAULT_VIEW} : "default";
+
+# Path to logs directory
+my $logdir = "$scm_base$/logs";
+
+error "Logdir $logdir does not exist - $!", 1 if !-d $logdir;
+
+sub Usage {
+ my $msg = shift;
+
+ display "ERROR: $msg\n" if defined $msg;
+
+ display "Usage: $me\t[-u] [-v] [-d] [-n <# of days>]
+
+Where:
+
+ -u: Display usage
+ -v: Turn on verbose mode
+ -d: Turn on debug mode
+ -n: Number of days to report (Default: 1)
+
+Note: Number of days is relative to midnight. Output is to a logfile named
+activity.<date>.log. Since we want <date> to be accurate this script attempts
+to have each log file have only that days activity. Therefore -n 1 will report
+everything in the last full 24 hour day, -n2 will be the last two full 24 hour
+days, etc.
+";
+ exit 1;
+} # Usage
+
+my $today = time;
+
+sub ReportActivity {
+ my $view = shift;
+ my $since = shift;
+
+ my $cc = Clearcase->new;
+ # This is Unix only!
+ my $cmd = "$Clearcase::cleartool setview -exec \"$Clearcase::cleartool lshistory -since $since -avobs -fmt '%Nd;%Fu;%u@%h;%e;%n\\n'\" $view";
+
+ open OUTPUT, "$cmd|"
+ or error "Unable to open pipe for $cmd", 1;
+
+ my $today_ymd = YMD;
+ my $date = YMD;
+ my $logfile;
+
+ while (<OUTPUT>) {
+ # Split the line into fields. The first field is date and time
+ my @fields = split /;/;
+
+ # Now split the first field by "." which separates the date and time
+ @fields = split /\./, $fields [0];
+
+ # Never report today's activity because today's never over!
+ # Reporting on today may give a partial result
+ next if $fields [0] eq $today_ymd;
+
+ # Ugh - might have stuff that's future dated!
+ next if $fields [0] gt $today_ymd;
+
+ # Skip noise. In this case noise is activity to the perftest
+ # vob. No normal activity happens to perftest - just performance
+ # testing.
+ next if /${Clearcase::vobtag_prefix}perftest/;
+
+ if ($fields [0] lt $date) {
+ $date = $fields [0];
+ my $log_filename = $cc->sitename . ".activity.$date";
+ verbose "Starting logfile $log_filename";
+ $logfile = undef;
+ $logfile = Logger->new (name => $log_filename, path => $logdir);
+ } # if
+
+ chomp;
+ $logfile->log ($_);
+ } # while
+
+ close OUTPUT;
+} # ReportActivity
+
+my $nbr_days = 1;
+
+while ($ARGV [0]) {
+ if ($ARGV [0] eq "-v") {
+ Display::set_verbose;
+ } elsif ($ARGV [0] eq "-d") {
+ set_debug;
+ } elsif ($ARGV [0] eq "-n") {
+ shift @ARGV;
+ if ($ARGV [0]) {
+ $nbr_days = $ARGV [0];
+ } else {
+ Usage "Need to specify nbr_days after -n";
+ } # if
+ } elsif ($ARGV [0] eq "-u") {
+ Usage;
+ } else {
+ Usage "Invalid argument: $ARGV [0]";
+ } # if
+
+ shift (@ARGV);
+} # while
+
+my $date = YMD;
+
+verbose "Creating view $tag";
+my $view = Clearcase::View->new (tag => $tag);
+$view->create;
+
+verbose "Mounting all vobs";
+my $vobs = Clearcase::Vobs->new;
+$vobs->mount;
+
+# Compute $since
+my $seconds_in_day = 60 * 60 * 24;
+my $since = YMD ($today - ($nbr_days * $seconds_in_day));
+
+verbose "Producing report";
+ReportActivity $tag, $since;
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: lscset,v
+# Revision: 1.1.1.1
+# Description: This script will list change sets for activities
+# Author: Andrew@DeFaria.com
+# Created: Thu Apr 27 18:10:37 PDT 2006
+# Modified: 2007/05/17 07:45:48
+# Language: Perl
+#
+# (c) Copyright 2006, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/../lib";
+
+use OSDep;
+use Display;
+use Clearcase;
+use Utils;
+
+my $me = $FindBin::Script;
+
+# This is site specific - and problematic!
+my $pvob_name = "ilm_pvob";
+my $pvob = ($arch eq "windows" or $arch eq "cygwin") ?
+ "\\" . "$Clearcase::vobtag_prefix$pvob_name" :
+ "$Clearcase::vobtag_prefix$pvob_name";
+
+sub Usage {
+ my $msg = shift;
+
+ display "Usage: $me: <activity> [ <activity> ]";
+
+ if (defined $msg) {
+ error "$msg", 1;
+ } # if
+
+ exit 0;
+} # Usage
+
+sub GetChangeSet {
+ my $activity = shift;
+ my $current_view = shift;
+
+ my @changes;
+ my $cmd = "cleartool lsactivity -l $activity\@$pvob 2>&1";
+ my @output = `$cmd`;
+ my $status = $?;
+
+ if ($status ne 0) {
+ warning "$activity Activity does not exist";
+ return;
+ } else {
+ my $found_changeset = $false;
+
+ foreach (@output) {
+ if (!$found_changeset) {
+ if (/ change set versions/) {
+ $found_changeset = $true;
+ next;
+ } else {
+ next;
+ } # if
+ } else {
+ if (/\s*(.*)/) {
+ my $element = $1;
+ # Trim off view stuff
+ if ($element =~ /$current_view(.*)/) {
+ $element = $1;
+ } # if
+ push @changes, $element;
+ } # if
+ } # if
+ } # foreach
+
+ return @changes;
+ } # if
+} # GetChangeSet
+
+sub GetPWV {
+ my $cmd = "cleartool pwv -s";
+ my @output = `$cmd`;
+ chomp @output;
+ my $status = $?;
+
+ my $view = $output [0];
+ chop $view if $view =~ /\r/;
+
+ if ($status ne 0 or $view =~ /\*\* NONE \*\*/) {
+ return undef;
+ } else {
+ return $view;
+ } # if
+} # GetPWV
+
+sub DisplayChangeSet {
+ my $activity = shift;
+ my @changes = @_;
+
+ display "$_" foreach (@changes);
+} # DisplayChangeSet
+
+Usage "Must specify an activity" if !defined $ARGV [0];
+
+# Should probably make a constructor for Clearcase::View to return the
+# current view, if any.
+my $current_view = GetPWV;
+
+Usage "Must be in a view" if !$current_view;
+
+my @activity = @ARGV;
+
+DisplayChangeSet $_, GetChangeSet $_, $current_view foreach (@activity);
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: $RCSfile: lsnusers,v $
+# Revision: $Revision: 1.3 $
+# Description: This script will perform builds for ILM/HP.
+# Author: Andrew@DeFaria.com
+# Created: Mon Feb 13 10:35:34 PST 2006
+# Modified: $Date: 2011/08/31 21:57:06 $
+# Language: Perl
+#
+# (c) Copyright 2006, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/../lib";
+
+use Getopt::Long;
+
+use OSDep;
+use Display;
+use Utils;
+
+my $me = $FindBin::Script;
+
+# Pick up from the environment if the user specifies pvob
+my $pvob = $ENV{pvob};
+
+my @pvob_related_objects = (
+ "activity",
+ "stream",
+);
+
+sub Usage {
+ my $msg = shift;
+
+ display "Usage: $me: <object_selector>";
+
+ if (defined $msg) {
+ error "$msg", 1;
+ } # if
+
+ exit 0;
+} # Usage
+
+Usage "Must specify an object selector" if !defined $ARGV [0];
+
+my $object = $ARGV [0];
+my $object_type = $object;
+my $full_object;
+
+$object_type =~ s/:.*//;
+
+if ($object =~ m/(.*)\@(.*)/) {
+ $object = $1;
+ $pvob = $2;
+} # if
+
+Usage "Must specify pvob or set pvob in your environment" if !$pvob;
+
+if (InArray $object_type, @pvob_related_objects) {
+ # Need to add additional "\\" because Windows will eat them up when executing a ``;
+ if ($arch eq "windows" or $arch eq "cygwin") {
+ $full_object = "$object\@\\$pvob";
+ } else {
+ $full_object = "$object\@$pvob";
+ } # if
+} else {
+ $full_object = $object;
+
+ # Handle oddity with windows using \ for vob tags
+ if ($full_object =~ /vob:\\(.*)/) {
+ $full_object = "vob:\\\\" . $1;
+ } # if
+} # if
+
+my $cmd = "cleartool lslock $full_object 2>&1";
+my @output = `$cmd`;
+my $status = $?;
+
+if ($status eq 0) {
+ if (scalar @output eq 0) {
+ display "$object is not locked";
+ exit 0;
+ } # if
+} else {
+ display "$object does not exist";
+ exit 1;
+} # if
+
+my @users;
+
+foreach (@output) {
+ if (/\"Locked except for users: (.*)\"/) {
+ @users = split " ", $1;
+ last;
+ } # if
+} # foreach
+
+if ((scalar @users) gt 0) {
+ display "Users excluded from lock for this $object_type include:";
+
+ foreach (sort @users) {
+ display "\t$_";
+ } # foreach
+} else {
+ display "This $object_type is locked from all users";
+} # if
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: $RCSfile: mknusers,v $
+# Revision: $Revision: 1.3 $
+# Description: This script will add a user to the nusers list for a lock
+# Author: Andrew@DeFaria.com
+# Created: Mon Feb 13 10:35:34 PST 2006
+# Modified: $Date: 2011/08/31 21:57:06 $
+# Language: Perl
+#
+# (c) Copyright 2006, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/../lib";
+
+use Getopt::Long;
+
+use OSDep;
+use Display;
+use Utils;
+
+my $me = $FindBin::Script;
+
+# Pick up from the environment if the user specifies pvob
+my $pvob = $ENV{pvob};
+
+my @pvob_related_objects = (
+ "activity",
+ "stream",
+);
+
+sub Usage {
+ my $msg = shift;
+
+ display "Usage: $me: <object_selector> <username> [<username>]";
+
+ if (defined $msg) {
+ error "$msg", 1;
+ } # if
+
+ exit 0;
+} # Usage
+
+sub AddNuser {
+ my $object = shift;
+ my $username = shift;
+ my @users = @_;
+
+ my $cmd = "cleartool lock -replace -nusers ";
+
+ foreach (@users) {
+ $cmd .= "$_,";
+ } # foreach
+
+ $cmd .= "$username $object";
+
+ my @output = `$cmd`;
+
+ return $?;
+} # AddNuser
+
+my $object = shift;
+my @users = @ARGV;
+
+Usage "Must specify an object selector" if !defined $object;
+Usage "Must specify an username" if scalar @users eq 0;
+
+my $object_type = $object;
+my $full_object;
+
+$object_type =~ s/:.*//;
+
+if ($object =~ m/(.*)\@(.*)/) {
+ $object = $1;
+ $pvob = $2;
+} # if
+
+Usage "Must specify pvob or set pvob in your environment" if !$pvob;
+
+if (InArray $object_type, @pvob_related_objects) {
+ # Need to add additional "\\" because Windows will eat them up when executing a ``;
+ if ($arch eq "windows" or $arch eq "cygwin") {
+ $full_object = "$object\@\\$pvob";
+ } else {
+ $full_object = "$object\@$pvob";
+ } # if
+} else {
+ $full_object = $object;
+
+ # Handle oddity with windows using \ for vob tags
+ if ($full_object =~ /vob:\\(.*)/) {
+ $full_object = "vob:\\\\" . $1;
+ } # if
+} # if
+
+foreach (@users) {
+ my $cmd = "cleartool lslock $full_object 2>&1";
+ my @output = `$cmd`;
+ my $status = $?;
+
+ if ($status ne 0) {
+ display "$object does not exist";
+ exit 1;
+ } # if
+
+ my @current_users;
+
+ foreach (@output) {
+ if (/\"Locked except for users: (.*)\"/) {
+ @current_users = split " ", $1;
+ last;
+ } # if
+ } # foreach
+
+ if (InArray $_, @current_users) {
+ error "User $_ is already on the nusers list for $object", 1;
+ } else {
+ if (AddNuser $full_object, $_, @current_users) {
+ error "Unable to add $_ to nusers list for $object", 2;
+ } else {
+ display "User $_ added to the list of nusers for $object";
+ } # if
+ } # if
+} # foreach
--- /dev/null
+#!/usr/bin/perl
+use strict;
+use warnings;
+
+=head2 NAME $RCSfile: mktriggers.pl,v $
+
+Enforce the application of triggers to vobs
+
+=head2 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision:
+
+$Revision: 1.6 $
+
+=item Created:
+
+Sat Apr 3 09:06:11 PDT 2003
+
+=item Modified:
+
+$Date: 2011/03/24 22:22:00 $
+
+=head2 SYNOPSIS
+
+ Usage: mktriggers.pl [-u|sage] [-[no]e|xec] [-[no]a|dd] [-[no]r|eplace]
+ [-[no]p|rivate] [ -vobs ] [-ve|rbose] [-d|ebug]
+
+ Where:
+
+ -u|sage: Displays usage
+ -[no]e|exec: Execute mode (Default: Do not execute)
+ -[no]a|dd: Add any missing triggers (Default: Don't add)
+ -[no]r|eplace: Replace triggers even if already present (Default:
+ Don't replace)
+
+ Note: If neither -add nor -replace is specified then
+ both -add and -replace are performed.
+
+ -triggers: Name of triggers.dat file (Default:
+ $FindBin::Bin/../etc/triggers.dat)
+ -[no]p|rivate: Process private vobs (Default: Don't process private
+ vobs)
+
+ -ve|rbose: Be verbose
+ -d|ebug: Output debug messages
+
+ -vob List of vob tags to apply triggers to (default all vobs)
+
+Note: You can specify -vob /vobs/vob1,/vobs/vob2 -vob /vobs/vob3 which will
+result in processing all of /vobs/vobs1, /vobs/vob2 and /vobs/vob3.
+
+=head2 DESCRIPTION
+
+This script parses triggers.dat and created trigger types in vobs. It is
+designed to be run periodically (cron(1)) and will add/replace triggers on
+all vobs by default. It can also operate on individual vobs if required. The
+script is driven by a data file, triggers.dat, which describes which triggers
+are to be enforced one which vobs.
+
+=head3 triggers.dat
+
+File format: Lines beginning with "#" are treated as comments Blank lines are
+skipped. Spaces and tabs can be used for whitespace.
+
+ # Globals
+ WinTriggerPath: \\<NAS device>\clearscm\triggers
+ LinuxTriggerPath: /net/<NAS device>/clearscm/triggers
+
+ # All vobs get the evil twin trigger
+ Trigger: EVILTWIN
+ Description: Evil Twin Prevention Trigger
+ Type: -all -element
+ Opkinds: -preop lnname
+ ScriptEngine: Perl
+ Script: eviltwin.pl
+ EndTrigger
+
+ # Only these vobs get this trigger to enforce a naming policy
+ # Note the trigger script gets a parameter
+ Trigger: STDNAMES
+ Description: Enforce standard naming policies
+ Type: -all -element
+ Opkinds: -preop lnname
+ ScriptEngine: Perl
+ Script: stdnames.pl -lowercase
+ Vobs: \dbengine, \backend
+ EndTrigger
+
+ # All vobs get rmelen trigger except ours!
+ Trigger: RMELEM
+ Description: Disable RMELEM
+ Type: -all -element
+ Opkinds: -preop lnname
+ ScriptEngine: Perl
+ Script: rmelem.pl
+ Novobs: \scm
+ EndTrigger
+
+=head2 ENVIRONMENT
+
+If the environment variable VEBOSE or DEBUG are set then it's as if -verbose
+or -debug was specified.
+
+=head2 COPYRIGHT
+
+Copyright (c) 2004 Andrew DeFaria , ClearSCM, Inc.
+All rights reserved.
+
+=cut
+
+use FindBin;
+
+use Getopt::Long;
+
+use lib "$FindBin::Bin/../lib";
+
+use Display;
+use OSDep;
+
+# Where is the trigger source code kept?
+my ($windows_trig_path, $linux_trig_path);
+
+# Where is the trigger definition file?
+my $etc_path = "$FindBin::Bin/../etc";
+my $triggerData = "$etc_path/triggers.dat";
+
+sub Usage (;$) {
+ my ($msg) = @_;
+
+ display $msg
+ if $msg;
+
+ system "perldoc $FindBin::Script";
+
+ exit 1;
+} # Usage
+
+sub ParseTriggerData {
+ open my $triggerData, '<', $triggerData
+ or error "Unable to open $triggerData - $!", 1;
+
+ my @triggers;
+ my ($name, $desc, $type, $opkinds, $engine, $script, $vobs, $novobs);
+
+ while (<$triggerData>) {
+ chomp; chop if /\r$/;
+
+ next if /^$/; # Skip blank lines
+ next if /^\#/; # and comments
+
+ s/^\s+//; # ltrim
+ s/\s+$//; # rtrim
+
+ if (/^\s*WinTriggerPath:\s*(.*)/i) {
+ $windows_trig_path = $1;
+ next;
+ } # if
+
+ if (/^\s*LinuxTriggerPath:\s*(.)/i) {
+ $linux_trig_path = $1;
+ next;
+ } # if
+
+ if (/^\s*Trigger:\s*(.*)/i) {
+ $name = $1;
+ next;
+ } # if
+
+ if (/^\s*Description:\s*(.*)/i) {
+ $desc = $1;
+ next;
+ } # if
+
+ if (/^\s*Type:\s*(.*)/i) {
+ $type = $1;
+ next;
+ } # if
+
+ if (/^\s*Opkinds:\s*(.*)/i) {
+ $opkinds = $1;
+ next;
+ } # if
+
+ if (/^\s*ScriptEngine:\s*(.*)/i) {
+ $engine = $1;
+ next;
+ } # if
+
+ if (/^\s*Script:\s*(.*)/i) {
+ $script = $1;
+ next;
+ } # if
+
+ if (/^\s*Vobs:\s*(.*)/i) {
+ $vobs = $1;
+ next;
+ } # if
+
+ if (/^\s*Novobs:\s*(.*)/i) {
+ $novobs = $1;
+ next;
+ } # if
+
+ if (/EndTrigger/) {
+ my %trigger;
+
+ $trigger{name} = $name;
+ $trigger{desc} = $desc;
+ $trigger{type} = $type;
+ $trigger{opkinds} = $opkinds;
+ $trigger{engine} = $engine;
+ $trigger{script} = $script;
+ $trigger{vobs} = !$vobs ? 'all' : $vobs;
+ $trigger{novobs} = $novobs ? $novobs : '';
+
+ push (@triggers, \%trigger);
+
+ $name = $desc = $type = $opkinds = $engine = $script = $vobs = $novobs = "";
+ } # if
+ } # while
+
+ close $triggerData;
+
+ error 'You must define WindowsTriggerPath, LinuxTriggerPath or both', 1
+ unless ($windows_trig_path or $linux_trig_path);
+
+ return @triggers;
+} # ParseTriggerData
+
+sub RemoveVobPrefix ($) {
+ my ($vob) = @_;
+
+ if ($ARCH =~ /windows/ or $ARCH =~ /cygwin/) {
+ $vob =~ s/^\\//;
+ } else {
+ $vob =~ s/^\/vobs\///;
+ } # if
+
+ return $vob;
+} # RemoveVobPrefix
+
+sub MkTriggerType ($$$$%) {
+ my ($vob, $exec, $add, $replace, %trigger) = @_;
+
+ my $replaceOpt = '';
+
+ # Need an extra set of "\\" for non Windows systems such as Cygwin
+ # since apparently the shell if envoked, collapsing a set of "\\".
+ my $vobtag = $ARCH =~ /cygwin/i ? "\\$vob" : $vob;
+ my $status = system ("cleartool lstype trtype:$trigger{name}\@$vobtag > $NULL 2>&1");
+
+ if ($status == 0) {
+ debug "Found pre-existing trigger $trigger{name}";
+
+ # If we are not replacing then skip by returning
+ return
+ unless $replace;
+
+ $replaceOpt = '-replace';
+ } else {
+ debug "No pre-existing trigger $trigger{name}";
+
+ # We need to add the trigger. However, if we are not adding then skip by
+ # returning
+ return
+ unless $add;
+ } # if
+
+ error "Sorry I only support ScriptEngines of Perl!" if $trigger{engine} ne "Perl";
+
+ my $win_engine = 'ccperl';
+ my $linux_engine = 'Perl';
+
+ my ($script, $parm) = split / /, $trigger{script};
+
+ $parm ||= '';
+
+ my ($win_script, $linux_script, $execwin, $execlinux);
+
+ $execwin = $execlinux = '';
+
+ if ($windows_trig_path) {
+ $win_script = $ARCH =~ /cygwin/i ? "\\\\$windows_trig_path\\$script"
+ : "$windows_trig_path\\$script";
+
+ warning "Unable to find trigger script $win_script ($!)"
+ if ($ARCH =~ /windows/i and $ARCH =~ /cygwin/) and not -e $win_script;
+
+ $execwin = "-execwin \"$win_engine $win_script $parm\" ";
+ } elsif ($linux_trig_path) {
+ $linux_script = "$linux_trig_path/$script";
+
+ warning "Unable to find trigger script $linux_script ($!)"
+ if ($ARCH !~ /windows/i and $ARCH !~ /cygwin/) and not -e $linux_script;
+
+ $execlinux = "-execwin \"$win_engine $win_script $parm\" ";
+ } # if
+
+ my $command =
+ 'cleartool mktrtype ' .
+ "$replaceOpt " .
+ "$trigger{type} " .
+ "$trigger{opkinds} " .
+ "-comment \"$trigger{desc}\" " .
+ $execwin .
+ $execlinux .
+ "$trigger{name}\@$vobtag " .
+ "> $NULL 2>&1";
+
+ debug "Command: $command";
+
+ $vob =~ s/\\\\/\\/;
+
+ $status = 0;
+ $status = system $command
+ if $exec;
+
+ if ($status) {
+ error "Unable to add trigger! Status = $status\nCommand: $command";
+ return 1;
+ } # if
+
+ if ($replaceOpt) {
+ if ($replace) {
+ if ($exec) {
+ display "Replaced trigger $trigger{name} in $vob";
+ } else {
+ display "[noexecute] Would have replaced trigger $trigger{name} in $vob";
+ } # if
+ } # if
+ } else {
+ if ($add) {
+ if ($exec) {
+ display "Added trigger $trigger{name} to $vob";
+ } else {
+ display "[noexecute] Would have added trigger $trigger{name} to $vob";
+ } # if
+ } # if
+ } # if
+
+ return;
+} # MkTriggerType
+
+sub VobType ($) {
+ my ($vob) = @_;
+
+ # Need an extra set of "\\" for non Windows systems such as Cygwin
+ # since apparently the shell if envoked, collapsing a set of "\\".
+ $vob = "\\" . $vob if $ARCH =~ /cygwin/;
+
+ my @lines = `cleartool describe vob:$vob`;
+
+ chomp @lines; chop @lines if $lines[0] =~ /\r$/;
+
+ foreach (@lines) {
+ return 'ucm'
+ if /AdminVOB \<-/;
+ } # foreach
+
+ return 'base';
+} # VobType
+
+sub MkTriggers ($$$$@) {
+ my ($vob, $exec, $add, $replace, @triggers) = @_;
+
+ TRIGGER: foreach (@triggers) {
+ my %trigger = %{$_};
+
+ my $vobname = RemoveVobPrefix $vob;
+
+ # Skip vobs on the novobs list
+ foreach (split /[\s+|,]/, $trigger{novobs}) {
+ my $vobtag = RemoveVobPrefix $_;
+
+ if ($vobname eq RemoveVobPrefix $_) {
+ debug "Skipping $vob (on novobs list)";
+ next TRIGGER;
+ } # if
+ } # foreach
+
+ # For triggers whose vob type is "all" or unspecified make the trigger
+ if ($trigger{vobs} eq 'all' || $trigger{vobs} eq '') {
+ MkTriggerType $vob, $exec, $add, $replace, %trigger;
+ } elsif ($trigger{vobs} eq 'base' || $trigger{vobs} eq 'ucm') {
+ # If vob type is "base" or "ucm" make sure the vob is of correct type
+ my $vob_type = VobType ($vob);
+
+ if ($vob_type eq $trigger{vobs}) {
+ MkTriggerType $vob, $exec, $add, $replace, %trigger;
+ } else {
+ verbose "Trigger $trigger{name} is for $trigger{vobs} vobs but $vob is a $vob_type vob - Skipping...";
+ } # if
+ } else {
+ my @Vobs = split /[\s+|,]/, $trigger{vobs};
+
+ # Otherwise we expect the strings in $triggers{vobs} to be space or comma
+ # separated vob tags so we make sure it matches this $vob.
+ foreach (@Vobs) {
+ if ($vobname eq RemoveVobPrefix $_) {
+ MkTriggerType $vob, $exec, $add, $replace, %trigger;
+ last;
+ } # if
+ } # foreach
+ } # if
+ } # foreach
+
+ return;
+} # MkTriggers
+
+my ($exec, $add, $replace, $private, @vobs) = (0, 0, 0, 0);
+
+GetOptions (
+ usage => sub { Usage },
+ verbose => sub { set_verbose },
+ debug => sub { set_debug },
+ 'triggers=s', \$triggerData,
+ 'exec!', \$exec,
+ 'add!', \$add,
+ 'replace!', \$replace,
+ 'private!', \$private,
+ 'vobs=s', \@vobs,
+) or Usage "Invalid parameter";
+
+# This allows comma separated parms like -vob vob1,vob2,etc.
+@vobs = split /,/, join (',', @vobs);
+
+# If the user didn't specify -add or -replace then toggle both on
+$add = $replace = 1
+ unless $add or $replace;
+
+# If the user didn't specify any -vobs then that means all vobs
+@vobs = `cleartool lsvob -short`
+ unless @vobs;
+
+chomp @vobs; chop @vobs if $vobs[0] =~ /\r/;
+
+# Parse the triggers.dat file
+debug "Parsing trigger data ($triggerData)";
+
+my @triggers = ParseTriggerData;
+
+# Iterrate through the list of vobs
+debug 'Processing ' . scalar @vobs . ' vobs';
+
+foreach (sort @vobs) {
+ # Need an extra set of "\\" for non Windows systems such as Cygwin
+ # since apparently the shell if envoked, collapsing a set of "\\".
+ my $vob = $ARCH =~ /cygwin/i ? "\\$_" : $_;
+ my $line = `cleartool lsvob $vob`;
+
+ # Skip private vobs
+ unless ($private) {
+ if ($line =~ / private/) {
+ verbose "Skipping private vob $vob...";
+ next;
+ } # if
+ } # unless
+
+ $vob =~ s/\\\\/\\/;
+
+ debug "Applying triggers to $vob...";
+
+ MkTriggers $_, $exec, $add, $replace, @triggers;
+} # foreach
+
+debug 'All triggers applied';
--- /dev/null
+<!--
+File: index.php,v
+Revision: 1.1.1.1
+
+Description: Manage Stream Locks. This web application allows managers to manage
+ locks on UCM streams. Security is provided through simple Basic
+ Authentication provided by the web server.
+
+Author: Andrew@DeFaria.com
+Created: Fri Jul 14 09:44:04 PDT 2006
+Modified: 2007/05/17 07:45:48
+Language: PHP
+
+(c) Copyright 2006, Andrew@DeFaria.com, all rights reserved.
+-->
+
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+ <link rel="stylesheet" type="text/css" href="/css/default.css">
+<?php
+include_once ("streams.php");
+
+$version = "1.0";
+
+$heading = "Manage Stream Locks";
+?>
+ <title><?php echo $heading?></title>
+</head>
+
+<center><h1><?php echo $heading?></h1></center>
+
+<p>Popular Streams:</p>
+
+<ul>
+ <li><a href="lsnusers.php?stream=RISS15_Integration">RISS15_Integration</a></li>
+ <li><a href="lsnusers.php?stream=RISS151_Integration">RISS151_Integration</a></li>
+ <li><a href="lsnusers.php?stream=osaka_strm">osaka_strm</a></li>
+</ul>
+
+<center>
+<form method="get"
+ action="lsnusers.php"
+ name="select_stream">
+
+<p><b>All streams:</b> <select name="stream" class="inputfield">
+<?php
+$streams = get_streams ();
+sort ($streams);
+
+foreach ($streams as $stream) {
+ print "<option>$stream</option>\n";
+} // foreach
+?>
+</select>
+
+ <input type="submit" value="Select"></p>
+</form>
+
+<p><small><a href="/">Back to main build page</a></small></p>
+</center>
+<?php copyright (null ,$version);?>
+</body>
+</html>
--- /dev/null
+<!--
+File: lsnusers.php,v
+Revision: 1.1.1.1
+
+Description: List users on the exclusion list (-nusers) for the stream lock.
+
+Author: Andrew@DeFaria.com
+Created: Fri Jul 14 09:44:04 PDT 2006
+Modified: 2007/05/17 07:45:48
+Language: PHP
+
+(c) Copyright 2006, Andrew@DeFaria.com, all rights reserved.
+-->
+
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+ <link rel="stylesheet" type="text/css" href="/css/default.css">
+<?php
+include_once ("streams.php");
+$version = "1.0";
+
+# "Command line" parameters...
+if (!empty ($_GET ["stream"])) {
+ $stream = $_GET ["stream"];
+ $heading = "Stream Locks for stream $stream";
+} else {
+ $heading = "Stream Locks for stream <unknown>:";
+} // if
+
+?>
+ <title><?php echo $heading?></title>
+</head>
+
+<center><h1><?php echo $heading?></h1></center>
+
+<?php
+if (empty ($stream)) {
+ error ("Stream not specified!");
+} // if
+
+$nlocked_users = get_nusers ($stream);
+$nlocked_usernames = get_usernames ();
+
+if (!empty ($nlocked_users)) {
+ print "<p>Users excluded from lock for this stream include:</p>\n";
+ print "<blockquote>\n";
+ sort ($nlocked_users);
+ foreach ($nlocked_users as $user) {
+ //print "<li>$user <small><a href=\"private/rmnusers.php?stream=$stream&user=$user\">delete</a></small></li>\n";
+ print "<a href=\"private/rmnusers.php?stream=$stream&user=$user\"><img align=top src=\"delete.gif\" alt=\"delete\" heigth=15 width=15 border=0></a> ";
+ if (array_key_exists ($user, $nlocked_usernames)) {
+ print $nlocked_usernames{$user};
+ } else {
+ print $user;
+ } // if
+ print "<br>\n";
+ } // foreach
+} else {
+ print "<b><font color=red>Stream $stream is not locked.</font></b>";
+} // if
+
+print "</blockquote>\n";
+print "<p><a href=\"private/addnuser.php?stream=$stream\">Add new user</a></p>\n";
+?>
+
+<center>
+<p><small><a href="/nusers_stream">Manage Stream Locks Home</a></small></p>
+<?php copyright (null ,$version);?>
+</center>
+</body>
+</html>
--- /dev/null
+<!--
+File: addnuser.php,v
+Revision: 1.1.1.1
+
+Description: Pick a user to be added to the exclusion list (-nusers).
+
+Author: Andrew@DeFaria.com
+Created: Fri Jul 14 09:44:04 PDT 2006
+Modified: 2007/05/17 07:45:48
+Language: PHP
+
+(c) Copyright 2006, Andrew@DeFaria.com, all rights reserved.
+-->
+
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+ <link rel="stylesheet" type="text/css" href="/css/default.css">
+<?php
+include_once ("../streams.php");
+$version = "1.0";
+
+if (!empty ($_GET ["stream"])) {
+ $stream = $_GET ["stream"];
+} // if
+
+if (!empty ($stream)) {
+ $heading = "Select user to allow access to $stream";
+} else {
+ $heading = "Select user to allow access to <unknown>";
+} // if
+?>
+ <title><?php echo $heading?></title>
+</head>
+
+<center><h1><?php echo $heading?></h1></center>
+
+<?php
+// Santity check
+if (empty ($stream)) {
+ error ("Stream parameter not supplied");
+} // if
+
+$users = get_usernames ();
+asort ($users);
+print "<center><form method=\"get\" action=\"mknusers.php\" name=\"add_nuser\">\n";
+print "<input type=hidden name=stream value=$stream>\n";
+print "<select name=\"user\" class=\"inputfield\">\n";
+foreach ($users as $key => $user) {
+ print "<option>$user</option>\n";
+} // foreach
+?>
+</select>
+
+ <input type="submit" value="Select"></p>
+</form></center>
+
+<center>
+<p><small><a href="/nusers_stream">Manage Stream Locks Home</a></small></p>
+<?php copyright (null ,$version);?>
+</center>
+</body>
+</html>
--- /dev/null
+<!--
+File: mknusers.php,v
+Revision: 1.1.1.1
+
+Description: Add a user to the exclusion list (-nusers).
+
+Author: Andrew@DeFaria.com
+Created: Fri Jul 14 09:44:04 PDT 2006
+Modified: 2007/05/17 07:45:48
+Language: PHP
+
+(c) Copyright 2006, Andrew@DeFaria.com, all rights reserved.
+-->
+
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+ <link rel="stylesheet" type="text/css" href="/css/default.css">
+<?php
+include_once ("../streams.php");
+$version = "1.0";
+
+# "Command line" parameters...
+if (!empty ($_GET ["stream"])) {
+ $stream = $_GET ["stream"];
+} // if
+if (!empty ($_GET ["user"])) {
+ $user = $_GET ["user"];
+} // if
+
+if (!empty ($stream)) {
+ if (!empty ($user)) {
+ $heading = "Opening up $stream for $user";
+ } else {
+ $heading = "Opening up $stream for <unknown>";
+ } // if
+} else {
+ $heading = "Opening up <unknown> for $user";
+} // if
+?>
+ <title><?php echo $heading?></title>
+</head>
+
+<center><h1><?php echo $heading?></h1></center>
+
+<?php
+// Santity check
+if (empty ($stream)) {
+ error ("Stream parameter not supplied");
+} // if
+
+if (empty ($user)) {
+ error ("User parameter not supplied");
+} // if
+
+$usernames = get_usernames ();
+
+foreach ($usernames as $key => $value) {
+ if ($user == $value) {
+ $user = $key;
+ break;
+ } // if
+} // foreach
+
+$nusers = get_nusers ($stream);
+
+if (count ($nusers) == 0) {
+ $nusers [0] = $user;
+ $status = chnusers ($stream, $nusers);
+
+ if ($status == 0) {
+ print "$user is now allowed to access $stream";
+ } else {
+ print "<font color=red><b>ERROR:</b></font> Unable to add $user to nuser list of $stream";
+ } // if
+} elseif (is_member ($user, $nusers)) {
+ print "<font color=red><b>ERROR:</b></font> $user is already allowed access to $stream<br>";
+} else {
+ array_push ($nusers, $user);
+ $status = chnusers ($stream, $nusers);
+
+ if ($status == 0) {
+ print "$user is now allowed to access $stream";
+ } else {
+ print "<font color=red><b>ERROR:</b></font> Unable to add $user to nuser list of $stream";
+ } // if
+} // if
+?>
+
+<center>
+<p><small><a href="/nusers_stream/lsnusers.php?stream=<?=$stream?>">Manage Stream Locks for <?=$stream?></a></small></p>
+<?php copyright (null ,$version);?>
+</center>
+</body>
+</html>
--- /dev/null
+<!--
+File: rmnusers.php,v
+Revision: 1.1.1.1
+
+Description: Remove a user to the exclusion list (-nusers).
+
+Author: Andrew@DeFaria.com
+Created: Fri Jul 14 09:44:04 PDT 2006
+Modified: 2007/05/17 07:45:48
+Language: PHP
+
+(c) Copyright 2006, Andrew@DeFaria.com, all rights reserved.
+-->
+
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+ <link rel="stylesheet" type="text/css" href="/css/default.css">
+<?php
+include_once ("../streams.php");
+$version = "1.0";
+
+# "Command line" parameters...
+if (!empty ($_GET ["stream"])) {
+ $stream = $_GET ["stream"];
+} // if
+if (!empty ($_GET ["user"])) {
+ $user = $_GET ["user"];
+} // if
+
+if (!empty ($stream)) {
+ if (!empty ($user)) {
+ $heading = "Removing access of $user to $stream";
+ } else {
+ $heading = "Removing access of <unknown> to $stream";
+ } // if
+} else {
+ $heading = "Removing access of $user to <unknown>";
+} // if
+?>
+ <title><?php echo $heading?></title>
+</head>
+
+<center><h1><?php echo $heading?></h1></center>
+
+<?php
+// Santity check
+if (empty ($stream)) {
+ error ("Stream parameter not supplied");
+} // if
+
+if (empty ($user)) {
+ error ("User parameter not supplied");
+} // if
+
+$nusers = get_nusers ($stream);
+
+if (!is_member ($user, $nusers)) {
+ print "<font color=red><b>ERROR:</b></font> $user is already not allowed access to $stream<br>";
+} else {
+ $nusers = remove_from_array ($user, $nusers);
+ $status = chnusers ($stream, $nusers);
+
+ if ($status == 0) {
+ print "$user is no longer allowed to access $stream";
+ } else {
+ print "<font color=red><b>ERROR:</b></font> Unable to remove $user from $stream";
+ } // if
+} // if
+?>
+
+<center>
+<p><small><a href="/nusers_stream/lsnusers.php?stream=<?=$stream?>">Manage Stream Locks for <?=$stream?></a></small></p>
+<?php copyright (null ,$version);?>
+</center>
+</body>
+</html>
--- /dev/null
+<?php
+////////////////////////////////////////////////////////////////////////////////
+//
+// File: streams.php
+// Revision: 1.1.1.1
+// Description: Library to interface to Clearcase streams
+// Author: Andrew@DeFaria.com
+// Created: Wed Jul 5 10:14:02 PDT 2006
+// Modified: 2007/05/17 07:45:48
+// Language: PHP
+//
+// (c) Copyright 2006, Andrew@DeFaria.com, all rights reserved.
+//
+////////////////////////////////////////////////////////////////////////////////
+$version = "1.0";
+$pvob = "/vobs/ilm_pvob";
+$cleartool = "/opt/rational/clearcase/bin/cleartool";
+
+function debug ($msg) {
+ print "<b><font color=red>DEBUG:</font></b> $msg<br>\n";
+} // debug
+
+function error ($msg) {
+ print "<b><font color=red>ERROR:</font></b> $msg<br>\n";
+ exit (1);
+} // error
+
+function get_streams () {
+ global $pvob;
+ global $cleartool;
+
+ $cmd = "$cleartool lsstream -s -invob $pvob";
+
+ exec ($cmd, $output, $status);
+
+ if ($status != 0) {
+ print "Unable to execute command \"$cmd\" (Status: $status)<br>";
+ exit (1);
+ } // if
+
+ return $output;
+} // get_streams
+
+function get_usernames () {
+ $cmd = "ypcat passwd";
+
+ exec ($cmd, $lines, $status);
+
+ if ($status != 0) {
+ print "Unable to execute command \"$cmd\" (Status: $status)<br>";
+ exit (1);
+ } // if
+
+ $users = array ();
+
+ foreach ($lines as $line) {
+ $fields = explode (":", $line);
+ $users {$fields [0]} = $fields [4];
+ } // foreach
+
+ return $users;
+} // get_usernames
+
+function get_users () {
+ $cmd = "ypcat passwd";
+
+ exec ($cmd, $lines, $status);
+
+ if ($status != 0) {
+ print "Unable to execute command \"$cmd\" (Status: $status)<br>";
+ exit (1);
+ } // if
+
+ $users = array ();
+
+ foreach ($lines as $line) {
+ $fields = explode (":", $line);
+ array_push ($users, $fields [0]);
+ } // foreach
+
+ return $users;
+} // get_users
+
+function get_nusers ($stream) {
+ global $cleartool;
+ global $pvob;
+
+ $cmd = "$cleartool lslock stream:$stream@$pvob";
+
+ exec ($cmd, $output, $status);
+
+ if ($status != 0) {
+ print "Stream: $stream not found";
+ exit (1);
+ } else {
+ if (count ($output) == 0) {
+ return;
+ } // if
+ } // if
+
+ $nusers = array ();
+
+ foreach ($output as $line) {
+ if (preg_match ("/\"Locked except for users: (.*)\"/", $line, $matches)) {
+ $nusers = split (" ", $matches [1]);
+ } // if
+ } // foreach
+
+ return $nusers;
+} // get_nusers
+
+function is_member ($new_item, $array) {
+ if (empty ($new_item) || empty ($array)) {
+ return 0;
+ } // if
+
+ foreach ($array as $item) {
+ if ($new_item == $item) {
+ return 1;
+ } // if
+ } // foreach
+
+ return 0;
+} // is_member
+
+function remove_from_array ($removed_item, $array) {
+ $new_array = array ();
+
+ foreach ($array as $item) {
+ if ($removed_item != $item) {
+ array_push ($new_array, $item);
+ } // if
+ } // foreach
+
+ return $new_array;
+} // remove_from_array
+
+function chnusers ($stream, $users) {
+ $nusers = "";
+
+ foreach ($users as $user) {
+ if (empty ($nusers)) {
+ $nusers .= $user;
+ } else {
+ $nusers .= ",$user";
+ } // if
+ } // foreach
+
+ $current_nusers = get_nusers ($stream);
+
+ if (count ($current_nusers) == 0 || count ($users) == 0) {
+ $cmd = "./chnusers $stream $nusers";
+ } else {
+ $cmd = "./chnusers $stream $nusers replace";
+ } // if
+
+ exec ($cmd, $output, $status);
+
+ return $status;
+} // chnusers
+
+function copyright ($start_year = "", $version = "") {
+ $today = getdate ();
+ $current_year = $today ["year"];
+
+ $this_file = $_SERVER['PHP_SELF'];
+
+ // Handle user home web pages
+ if (preg_match ("/\/\~/", $this_file)) {
+ $this_file= preg_replace ("/\/\~(\w+)\/(\s*)/", "/home/$1/web$2/", $this_file);
+ } else {
+ $this_file = "/var/devenv/tiburon/" . $this_file;
+ } // if
+
+ $mod_time = date ("F d Y @ g:i a", filemtime ($this_file));
+
+ print <<<END
+<div class="copyright">
+Last modified: $mod_time<br>
+Copyright ©
+END;
+
+ if ($start_year != "") {
+ print "$start_year-";
+ } // if
+
+print <<<END
+$current_year <a href="http://www.hp.com/go/ilm">HP/Information Lifecycle Management Solutions</a><br>
+All rights reserved (
+END;
+
+print basename ($_SERVER ["PHP_SELF"], ".php");
+
+if ($version != "") {
+ print " V$version";
+} // if
+
+print ")\n</div>\n";
+} // copyright
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: pulse,v
+# Revision: 1.1.1.1
+# Description: Checks Clearcase's "pulse" by attempting to some rudimentary
+# Clearcase operations and timing them. Timing data is logged
+# for historical purposes.
+# Author: Andrew@DeFaria.com
+# Created: Thu Dec 29 12:07:59 PST 2005
+# Modified: 2007/05/17 07:45:48
+# Language: perl
+#
+# (c) Copyright 2005, Andrew@DeFaria.com, all rights reserved
+#
+################################################################################
+use strict;
+use warnings;
+use File::Spec;
+
+my $me;
+
+BEGIN {
+ # Set $lib_path
+ my $lib_path = $^O =~ /MSWin/ ? "\\\\brcm-irv\\dfs\\projects\\ccase\\SCM\\lib"
+ : "/projects/ccase/SCM/lib";
+
+ # Extract relative path and basename from script name.
+ $0 =~ /(.*)[\/\\](.*)/;
+
+ my $abs_path = (!defined $1) ? "." : File::Spec->rel2abs ($1);
+ $me = (!defined $2) ? $0 : $2;
+ $me =~ s/\.pl$//;
+
+ # Add the appropriate path to our modules to @INC array.
+ unshift @INC, "$lib_path";
+ unshift @INC, $ENV {SITE_PERL_LIBPATH} if defined $ENV {SITE_PERL_LIBPATH};
+ unshift @INC, "$abs_path";
+} # BEGIN
+
+use OSDep;
+use Display;
+use Logger;
+use Clearcase;
+use Clearcase::Vob;
+use Clearcase::View;
+use Clearcase::Element;
+use TimeUtils;
+
+my $version = "1.0";
+
+# We need a view context. We'll create this view if necessary.
+my $tag = "default";
+
+# Which vob are we going to use
+my $vobtag = "perftest";
+
+# We need an element to check out and in
+my $element_name = "testelement";
+
+# How long is too long?
+my $too_long = 60; # seconds;
+
+# How many times will we perform the checkout/in?
+my $iterations = 10;
+
+# Some options that we use
+my %identical = (
+ "-identical", "",
+ "-nc", "",
+);
+my %nc = (
+ "-nc", "",
+);
+my %rm = (
+ "-rm", "",
+);
+my %force = (
+ "-force", "",
+);
+
+my $log;
+my $view;
+my $step_start_time;
+
+# Path to logs directory
+my $logdir = "$scm_base$/logs";
+
+error "Logdir $logdir does not exist - $!", 1 if !-d $logdir;
+
+my $cc = Clearcase->new;
+
+sub Usage {
+ my $msg = shift;
+
+ display "ERROR: $msg\n" if defined $msg;
+
+ display "Usage:\t$me (v$version) [-u] [-v] [-d] [-view <viewtag>] [-vob <vobtag>]
+\t[-element <element>] [-t <n>] [-i <n>]
+
+Where:
+
+ -u: Display usage
+ -v: Turn on verbose mode
+ -d: Turn on debug mode
+ -view: View tag to create/use (Default: $tag)
+ -vob: Vob tag to use (Default $vobtag)
+ -element: Vob relative path to element to checkout/in (Default: $element_name)
+ -t <n>: Threshold of what is \"too long\" (Default $too_long seconds)
+ -i <n>: Number of iterations (default $iterations)
+";
+ exit 1;
+} # Usage
+
+sub Setup {
+ $log = Logger->new (
+ name => $cc->sitename . "." . $me,
+ path => $logdir,
+ timestamped => "true",
+ append => "true"
+ );
+
+ verbose "Startup";
+
+ # Set up view
+ verbose "Setting u p view $tag";
+ $view = Clearcase::View->new (tag => $tag);
+ $view->create;
+
+ $view->set;
+
+ # Set up vob
+ verbose "Setting up vob $vobtag";
+ my $vob = Clearcase::Vob->new (tag => $vobtag);
+
+ $log->err ("Vob $Clearcase::VOBTAG_PREFIX$vobtag doesn't exist", 1) if !$vob;
+
+ $vob->mount;
+
+ chdir "$Clearcase::VIEWTAG_PREFIX/$tag$Clearcase::VOBTAG_PREFIX$vobtag"
+ or $log->err ("Unable to chdir to vob root", 1);
+
+ # Create an element
+ verbose "Creating element $element_name";
+ my $size = 5;
+ my $meg = 1024 * 1024;
+ my $buf = 1024;
+ my $bytes_to_write = $size * $meg;
+ my $bytes_written = 0;
+
+ # Can we make a file in tmp?
+ open ELEMENT, ">$element_name"
+ or error "Unable to create element $element_name - $!", 1;
+
+ while ($bytes_written < $bytes_to_write) {
+ my $data = "." x $buf;
+
+ print ELEMENT $data;
+ $bytes_written += $buf;
+ } # while
+
+ close ELEMENT;
+
+ verbose "Setup complete";
+
+ return Clearcase::Element->create ($element_name);
+} # Setup
+
+sub Shutdown {
+ my $element = shift;
+
+ verbose "Shutdown";
+ verbose "Unchecking out $element->{name}";
+ $element->uncheckout (%rm);
+ verbose "Removing $element->{name}";
+ $element->remove (%force);
+
+ my $parent = Clearcase::Element->new (name => ".");
+
+ verbose "Canceling checkout of parent directory";
+ $parent->uncheckout;
+} # Shutdown
+
+sub Checkout_in {
+ my $element = shift;
+
+ verbose "Checking in $element->{name}";
+ $element->checkin (%identical);
+
+ verbose "Checking out $element->{name}";
+ $element->checkout (%nc);
+} # Checkout_in
+
+while ($ARGV [0]) {
+ if ($ARGV [0] eq "-v") {
+ Display::set_verbose;
+ } elsif ($ARGV [0] eq "-d") {
+ set_debug;
+ } elsif ($ARGV [0] eq "-u") {
+ Usage;
+ } elsif ($ARGV [0] eq "-view") {
+ shift @ARGV;
+ if ($ARGV [0]) {
+ $view = $ARGV [0];
+ } else {
+ Usage "Need to specify view after -view";
+ } # if
+ } elsif ($ARGV [0] eq "-vob") {
+ shift @ARGV;
+ if ($ARGV [0]) {
+ $too_long = $ARGV [0];
+ } else {
+ Usage "Need to specify vob after -vob";
+ } # if
+ } elsif ($ARGV [0] eq "-element") {
+ shift @ARGV;
+ if ($ARGV [0]) {
+ $too_long = $ARGV [0];
+ } else {
+ Usage "Need to specify vob relative path to element after -element";
+ } # if
+ } elsif ($ARGV [0] eq "-t") {
+ shift @ARGV;
+ if ($ARGV [0]) {
+ $too_long = $ARGV [0];
+ } else {
+ Usage "Need to specify number of seconds after -t";
+ } # if
+ } elsif ($ARGV [0] eq "-i") {
+ shift @ARGV;
+ if ($ARGV [0]) {
+ $too_long = $ARGV [0];
+ } else {
+ Usage "Need to specify number of iterations after -i";
+ } # if
+ } else {
+ Usage "Invalid argument: $ARGV [0]";
+ } # if
+
+ shift (@ARGV);
+} # while
+
+my $element = Setup;
+
+$log->err ("Unable to setup environment", 1) if !$element;
+
+$step_start_time = time;
+
+$log->msg ("Performing $iterations checkout/ins in view $tag vob $vobtag of element " . $element->name);
+for (my $i = 0; $i < $iterations; $i++) {
+ verbose "Iteration #" . ($i + 1);
+ Checkout_in $element;
+} # for
+
+my $end_time = time;
+
+display_duration $step_start_time, $log;
+
+if (($end_time - $step_start_time) > $too_long) {
+ my $msg = "Taking too long to perform $iterations checkout/ins\nShould take less than $too_long seconds";
+ $log->err ($msg);
+ error $msg;
+} # if
+
+Shutdown $element;
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: $RCSfile: rmnusers,v $
+# Revision: $Revision: 1.3 $
+# Description: This script will remove a user to the nusers list for a lock
+# Author: Andrew@DeFaria.com
+# Created: Mon Feb 13 10:35:34 PST 2006
+# Modified: $Date: 2011/08/31 21:57:06 $
+# Language: Perl
+#
+# (c) Copyright 2006, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/../lib";
+
+use Getopt::Long;
+
+use OSDep;
+use Display;
+use Utils;
+
+my $me = $FindBin::Script;
+
+# Pick up from the environment if the user specifies pvob
+my $pvob = $ENV{pvob};
+
+my @pvob_related_objects = (
+ "activity",
+ "stream",
+);
+
+sub Usage {
+ my $msg = shift;
+
+ display "Usage: $me: <object_selector> <username> [<username>]";
+
+ if (defined $msg) {
+ error "$msg", 1;
+ } # if
+
+ exit 0;
+} # Usage
+
+sub RemoveNuser {
+ my $object = shift;
+ my $username = shift;
+ my @users = @_;
+
+ my $cmd = "cleartool lock ";
+
+ $cmd .= "-replace ";
+
+ if (scalar @users gt 1) {
+ $cmd .= "-nusers ";
+
+ my $first = $true;
+
+ foreach (@users) {
+ next if $_ eq $username;
+ if ($first) {
+ $first = $false;
+ $cmd .= $_;
+ } else {
+ $cmd .= ",$_";
+ } # if
+ } # foreach
+ } # if
+
+ $cmd .= " $object";
+
+ my @output = `$cmd`;
+
+ return $?;
+} # RemoveNuser
+
+my $object = shift;
+my @users = @ARGV;
+
+Usage "Must specify an object selector" if !defined $object;
+Usage "Must specify an username" if scalar @users eq 0;
+
+my $object_type = $object;
+my $full_object;
+
+$object_type =~ s/:.*//;
+
+if ($object =~ m/(.*)\@(.*)/) {
+ $object = $1;
+ $pvob = $2;
+} # if
+
+Usage "Must specify pvob or set pvob in your environment" if !$pvob;
+
+if (InArray $object_type, @pvob_related_objects) {
+ # Need to add additional "\\" because Windows will eat them up when executing a ``;
+ if ($arch eq "windows" or $arch eq "cygwin") {
+ $full_object = "$object\@\\$pvob";
+ } else {
+ $full_object = "$object\@$pvob";
+ } # if
+} else {
+ $full_object = $object;
+
+ # Handle oddity with windows using \ for vob tags
+ if ($full_object =~ /vob:\\(.*)/) {
+ $full_object = "vob:\\\\" . $1;
+ } # if
+} # if
+
+foreach (@users) {
+ my $cmd = "cleartool lslock $full_object 2>&1";
+ my @output = `$cmd`;
+ my $status = $?;
+
+ if ($status eq 0) {
+ if (scalar @output eq 0) {
+ display "$object is not locked";
+ exit 0;
+ } # if
+ } else {
+ display "$object does not exist";
+ exit 1;
+ } # if
+
+ my @current_users;
+
+ foreach (@output) {
+ if (/\"Locked except for users: (.*)\"/) {
+ @current_users = split " ", $1;
+ last;
+ } # if
+ } # foreach
+
+ if (InArray $_, @current_users) {
+ if (RemoveNuser $full_object, $_, @current_users) {
+ error "Unable to remove $_ from nusers for $object";
+ } else {
+ display "User $_ removed from the list of nusers for $object";
+ } # if
+ } else {
+ error "User $_ is not on the nusers list for $object";
+ } # if
+} # foreach
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: $RCSfile: stats,v $
+# Revision: $Revision: 1.2 $
+# Description: Produce statistical reports about vobs and views at this site
+# For each vob create a log file that contains the following data:
+#
+# date_time;site;VOB_name;size of database;size of source pool;size of devired object;size of cleartext;size of admin data;#elements;#branches;#versions
+#
+# Author: Andrew@DeFaria.com
+# Created: Mon Jan 2 17:23:08 PST 2006
+# Modified: $Date: 2007/05/17 07:45:48 &
+# Language: Perl
+#
+# (c) Copyright 2006-2010, Andrew@ClearSCM.com, all rights reserved.
+#
+#################################################################################
+use strict;
+use warnings;
+
+use File::Spec;
+use FindBin;
+use Getopt::Long;
+
+use lib "$FindBin::Bin/../lib";
+
+use OSDep;
+use Logger;
+use Display;
+use DateUtils;
+use Clearcase;
+use Clearcase::Vobs;
+use Clearcase::Vob;
+use Clearcase::Views;
+
+my $cc = Clearcase->new;
+my $site = $cc->sitename;
+my $logdir = '.';
+my $sitelog = "$site.site";
+my $voblog = "$site.vob";
+
+sub Usage {
+ my $msg = shift;
+
+ display "ERROR: $msg\n" if defined $msg;
+
+ display "Usage: $FindBin::Script\t[-u] [-v] [-d] [-vobs] [-site]
+
+Where:
+
+ -u|sage: Display usage
+ -ve|rbose: Turn on verbose mode
+ -d|ebug: Turn on debug mode
+ -vo|bs: Produce vob stats
+ -s|ite: Produce site stats
+ -l|ogpath: Directory to put logs (Default '.')
+
+Default is to report both the vobs and site statistics.
+";
+ exit 1;
+} # Usage
+
+my $do_vobs = 0;
+my $do_site = 0;
+
+GetOptions (
+ 'usage' => sub { Usage },
+ 'verbose' => sub { set_verbose },
+ 'debug' => sub { set_debug },
+ 'vobs', \$do_vobs,
+ 'site', \$do_site,
+ 'logdir=s', \$logdir,
+) or Usage 'Invalid parameter';
+
+unless ($do_vobs or $do_site) {
+ $do_vobs = $do_site = 1;
+} # if
+
+my $datetime = YMDHM;
+my $vobs = Clearcase::Vobs->new;
+my $total_vobsize = 0;
+
+if ($do_vobs) {
+ verbose 'Processing vobs...';
+
+ my $log = Logger->new (
+ path => $logdir,
+ name => $voblog,
+ append => 1,
+ );
+
+ foreach ($vobs->vobs) {
+ verbose "Processing vob: $Clearcase::vobtag_prefix$_";
+ my $vob = Clearcase::Vob->new (tag => "$Clearcase::vobtag_prefix$_");
+
+ my $elements = $vob->elements;
+ my $branches = $vob->branches;
+ my $versions = $vob->versions;
+
+ $log->msg (
+ "$datetime;$site" . ';' .
+ $_ . ';' .
+ $vob->dbsize . ';' .
+ $vob->srcsize . ';' .
+ $vob->dosize . ';' .
+ $vob->ctsize . ';' .
+ $vob->admsize . ';' .
+ $vob->size . ';' .
+ $vob->elements . ';' .
+ $vob->branches . ';' .
+ $vob->versions
+ );
+
+ $total_vobsize += $vob->size;
+ } # foreach
+} # if
+
+if ($do_site) {
+ verbose 'Processing site stats...';
+
+ my $log = Logger->new (
+ path => $logdir,
+ name => $sitelog,
+ append => 1,
+ );
+
+ my $views = Clearcase::Views->new;
+ my $nbr_views = $views->views;
+
+ $datetime = YMDHM;
+
+ $log->msg (
+ "$datetime;$site" . ';' .
+ $vobs->vobs . ';' .
+ $total_vobsize . ';' .
+ $views->dynamic . ';' .
+ $views->snapshot . ';' .
+ $views->ucm . ';' .
+ $views->web
+ );
+} # if
--- /dev/null
+################################################################################
+#
+# File: testcc.conf
+# Revision: 2.0
+# Description: Parameters for testcc
+#
+# Author: Andrew@DeFaria.com
+# Created: Thu Sep 6 14:05:55 MST 2007
+# Modified:
+# Language: Conf
+#
+# (c) Copyright 2007, Andrew@DeFaria.com, all rights reserved.
+#
+#################################################################################
+vobhost: gdvob1
+vobpath: /net/$vobhost
+vobstore: $vobpath/local/gdvob1a
+
+viewhost: view1
+viewpath: /net/$viewhost
+viewstore: $viewpath/local/view1a
\ No newline at end of file
--- /dev/null
+#!/bin/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: testcc.pl,v $
+
+Test Clearcase
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.6 $
+
+=item Created:
+
+Tue Apr 10 13:14:15 CDT 2007
+
+=item Modified:
+
+$Date: 2011/01/09 01:01:32 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage testcc.pl: [-u|sage] [-ve|rbose] [-d|ebug]
+ [-c|onfig <file>] [-vi|ewstore <viewstore>]
+ [-vo|bstore <vobstore>]
+
+ Where:
+ -u|sage: Displays usage
+
+ -ve|rbose: Be verbose
+ -d|ebug: Output debug messages
+
+ -c|onfig <file>: Config file (Default: testcc.conf)
+ -vi|ewstore: Path to view storage area
+ -vo|bstore: Path to vob storage area
+
+=head1 DESCRIPTION
+
+Clearcase smoke tests. Perform simple Clearcase operations to validate that
+Clearcase minimally works
+
+=cut
+
+use strict;
+use warnings;
+
+use FindBin;
+use Getopt::Long;
+use Cwd;
+use Term::ANSIColor qw(:constants);
+
+my $libs;
+
+BEGIN {
+ $libs = $ENV{SITE_PERLLIB} ? $ENV{SITE_PERLLIB} : "$FindBin::Bin/../lib";
+
+ die "Unable to find libraries\n"
+ unless -d $libs;
+} # BEGIN
+
+use lib $libs;
+
+use Clearcase;
+use Clearcase::Element;
+use Clearcase::View;
+use Clearcase::Views;
+use Clearcase::Vob;
+use Clearcase::Vobs;
+use DateUtils;
+use Display;
+use GetConfig;
+use Logger;
+use OSDep;
+use Utils;
+
+# Globals
+my $VERSION = '2.0';
+
+my ($vbs, $vws, %default_opts, %opts);
+
+my $log = Logger->new;
+my $view = $Clearcase::VIEWTAG_PREFIX;
+my $view_tag = $FindBin::Script;
+my $vob = $ENV{TMP} ? $ENV{TMP} : "/tmp"; # Private vob - mount to /tmp!
+my $vob_tag = $view_tag;
+
+my ($test_view, $test_vob);
+
+# LogOpts: Log the %opts has to the log file so we can tell the options used for
+# this run.
+sub LogOpts () {
+ $log->msg (
+ "$FindBin::Script v$VERSION run at "
+ . YMDHM
+ . " with the following options:"
+ );
+
+ foreach (sort keys %opts) {
+ if (ref $opts{$_} eq "ARRAY") {
+ my $name = $_;
+ $log->msg ("$name:\t$_") foreach (@{$opts{$_}});
+ } else {
+ $log->msg ("$_:\t$opts{$_}");
+ } # if
+ } # foreach
+
+ return;
+} # LogOpts
+
+sub CreateVob () {
+ $log->msg ("Creating vob $vob/$vob_tag");
+
+ $test_vob = Clearcase::Vob->new ("$vob/$vob_tag");
+
+ my ($status, @output) = $test_vob->create ($opts{vobhost}, $vbs);
+
+ $log->log ($_) foreach (@output);
+
+ if ($status != 0) {
+ if ($output[0] =~ /already exists/) {
+ $log->warn ("Vob " . $test_vob->tag . " already exists");
+ return 0;
+ } # if
+ } # if
+
+ return $status;
+} # CreateVob
+
+sub MountVob () {
+ $log->msg ("Mounting vob " . $test_vob->tag);
+
+ # Create mount directory
+ my ($status, @output) = Execute "mkdir -p " . $test_vob->tag . " 2>&1";
+
+ $log->log ($_) foreach (@output);
+
+ ($status, @output) = $test_vob->mount;
+
+ $log->log ($_) foreach (@output);
+
+ return $status;
+} # MountVob
+
+sub DestroyVob () {
+ my ($status, @output);
+
+ ($status, @output) = $Clearcase::CC->execute ("cd");
+
+ $log->msg ("Unmounting vob " . $test_vob->tag);
+
+ ($status, @output) = $test_vob->umount;
+
+ $log->msg ("Removing vob " . $test_vob->tag);
+
+ ($status, @output) = $test_vob->remove;
+
+ $log->log ($_) foreach (@output);
+
+ ($status, @output) = Execute "rmdir " . $test_vob->tag;
+
+ $log->log ($_)
+ foreach (@output);
+
+ return $status;
+} # DestroyVob
+
+sub CreateView () {
+ $log->msg ("Creating view $view_tag");
+
+ $test_view = Clearcase::View->new ($view_tag);
+
+ my ($status, @output) = $test_view->create ($opts{viewhost}, $vws);
+
+ $log->log ($_) foreach (@output);
+
+ if ($status != 0) {
+ if ($output[0] =~ /already exists/) {
+ $log->warn ("View " . $test_view->tag . " already exists");
+ return 0;
+ } # if
+ } # if
+
+ return $status;
+} # CreateView
+
+sub SetView () {
+ $log->msg ("Setting view $test_view->tag");
+
+ my ($status, @output) = $test_view->set;
+
+ $log->log ($_) foreach (@output);
+
+ return $status;
+} # SetView
+
+sub DestroyView () {
+ $log->msg ("Removing view " . $test_view->tag);
+
+ my ($status, @output) = $Clearcase::CC->execute ("cd");
+
+ $log->log ($_) foreach (@output);
+
+ chdir $ENV{HOME}
+ or $log->err ("Unable to chdir $ENV{HOME}", 1);
+
+ ($status, @output) = $test_view->remove;
+
+ $log->log ($_) foreach (@output);
+
+ return $status;
+} # DestroyView
+
+sub CreateViewPrivateFiles (@) {
+ my (@elements) = @_;
+
+ $log->msg ("Creating test files");
+
+ foreach (@elements) {
+ my $file;
+
+ $log->msg ("Creating $_");
+
+ open $file, ">>", $_
+ or $log->err ("Unable to open $_ for writing - $!", 1);
+
+ print $file "This is file $_\n";
+
+ close $file;
+ } # foreach
+
+ return;
+} # CreateViewPrivateFiles
+
+sub CheckOut ($) {
+ my ($element) = @_;
+
+ my ($status, @output);
+
+ if (ref $element eq "ARRAY") {
+ foreach (@{$element}) {
+ $log->msg ("Checking out $_");
+
+ my $newElement = Clearcase::Element->new ($_);
+
+ ($status, @output) = $newElement->checkout;
+
+ $log->log ($_) foreach (@output);
+ $log->err ("Unable to check out $_", $status) if $status;
+ } # foreach
+ } else {
+ $log->msg ("Checking out $element");
+
+ my $newElement = Clearcase::Element->new ($element);
+
+ ($status, @output) = $newElement->checkout;
+
+ $log->log ($_) foreach (@output);
+ $log->err ("Unable to check out $element", $status) if $status;
+ } # if
+
+ return;
+} # CheckOut
+
+sub CheckIn ($) {
+ my ($element) = @_;
+
+ my ($status, @output);
+
+ if (ref $element eq "ARRAY") {
+ foreach (@{$element}) {
+ $log->msg ("Checking in $_");
+
+ my $newElement = Clearcase::Element->new ($_);
+
+ ($status, @output) = $newElement->checkin;
+
+ $log->log ($_) foreach (@output);
+ $log->err ("Unable to check in $_", $status) if $status;
+ } # foreach
+ } else {
+ $log->msg ("Checking in $element");
+
+ my $newElement = Clearcase::Element->new ($element);
+
+ ($status, @output) = $newElement->checkin;
+
+ $log->log ($_) foreach (@output);
+ $log->err ("Unable to check in $element", $status) if $status;
+ } # if
+
+ return;
+} # CheckIn
+
+sub ComparingFiles (@) {
+ my (@elements) = @_;
+
+ foreach (@elements) {
+ my @lines = ReadFile $_;
+
+ $log->err ("Element $_ should contain only two lines", 2) if scalar @lines != 2;
+ } # foreach
+
+ return;
+} # ComparingFiles
+
+sub MakeElements (@) {
+ my (@elements) = @_;
+
+ foreach (@elements) {
+ $log->msg ("Mkelem $_");
+
+ my $newElement = Clearcase::Element->new ($_);
+
+ my ($status, @output) = $newElement->mkelem;
+
+ $log->log ($_) foreach (@output);
+ $log->err ("Unable to make $_ an element", $status) if $status;
+ } # foreach
+
+ return;
+} # MakeElements
+
+sub RunTests () {
+ # Simple tests:
+ #
+ # . Create a few elements
+ # . Check them in
+ # . Check them out
+ # . Modify them
+ # . Check them in
+ #
+ # Assumptions:
+ #
+ # . $vob_tag is already created
+ # . $view_tag is already created
+ # . View is set and we are in the vob
+ # . There are no vob elements for @elements
+ my @elements = (
+ "cctest.h",
+ "ccsetup.c",
+ "cctest.c",
+ "Makefile",
+ );
+
+ $log->msg ("Removing test files");
+
+ unlink $_ foreach (@elements);
+
+ $log->msg ("Creating view private files");
+
+ CreateViewPrivateFiles $log, @elements;
+
+ $log->msg ("Making elements");
+
+ CheckOut '.';
+ MakeElements @elements;
+ CheckIn \@elements;
+ CheckIn '.';
+
+ $log->msg ("Checking out files");
+
+ CheckOut \@elements;
+
+ $log->msg ("Modifying files");
+
+ CreateViewPrivateFiles @elements;
+
+ $log->msg ("Checking in files");
+
+ CheckIn \@elements;
+
+ $log->msg ("Comparing files");
+
+ ComparingFiles @elements;
+
+ $log->msg ("$FindBin::Script: End Tests");
+
+ return 0;
+} # RunTests
+
+sub Cleanup () {
+ my $status = 0;
+
+ $log->msg ("Cleaning up");
+
+ if ($test_view && $test_view->exists) {
+ $status += DestroyView;
+ } # if
+
+ if ($test_vob && $test_vob->exists) {
+ $status += DestroyVob;
+ } # if
+
+ return $status;
+} # Cleanup
+
+sub SetupTest () {
+ $log->msg ("Setup test environment");
+
+ my $status += CreateVob;
+
+ return $status if $status != 0;
+
+ $status += MountVob;
+
+ return $status if $status != 0;
+
+ $status += CreateView;
+
+ return $status if $status != 0;
+
+ $status += $test_view->start;
+
+ my $dir = $Clearcase::VIEWTAG_PREFIX . $test_view->tag . $test_vob->tag;
+
+ chdir $dir
+ or $log->err ("Unable to chdir to $dir", $status++);
+
+ my @output;
+
+ ($status, @output) = $Clearcase::CC->execute ("cd $dir");
+
+ if ($status != 0) {
+ $log->log ($_) foreach (@output);
+ $log->err ("Unable to chdir to $dir", $status);
+ } # if
+
+ return $status;
+} # SetupTest
+
+my $conf_file = "$FindBin::Script.conf";
+
+GetOptions (
+ \%opts,
+ "v|verbose" => sub { set_verbose },
+ "u|usage" => sub { Usage },
+ "c|onfig=s",
+ "n|etpath=s",
+ "viewstore=s",
+ "vobstore=s",
+) or Usage;
+
+# Read the config file
+if (-f $conf_file) {
+ %default_opts = GetConfig $conf_file;
+} else {
+ $log->err ("Unable to find config file $conf_file", 1);
+} # if
+
+# Overlay default opts if not specified
+foreach (keys %default_opts) {
+ $opts{$_} = $default_opts{$_} if !$opts{$_};
+} # foreach
+
+$vws = "$opts{viewstore}/$view_tag.vws";
+$vbs = "$opts{vobstore}/$vob_tag.vbs";
+
+$log->msg ("START: $FindBin::Script (v$VERSION)");
+
+LogOpts;
+
+my $status = SetupTest;
+
+if ($status == 0) {
+ $status += RunTests;
+} else {
+ $log->err ("Tests not run. Failure occured in SetupTest - check logfile");
+} # if
+
+$status += Cleanup;
+
+if ($status != 0) {
+ $log->err ("$FindBin::Script failed");
+} else {
+ $log->msg ("$FindBin::Script passed");
+} # if
+
+$log->msg ("END: $FindBin::Script (v$VERSION)");
+
+exit $status;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<Cwd>
+
+L<FindBin>
+
+L<Getopt::Long|Getopt::Long>
+
+L<Term::ANSIColor|Term::ANSIColor>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ Clearcase
+ Clearcase::Element
+ Clearcase::View
+ Clearcase::Views
+ Clearcase::Vob
+ Clearcase::Vobs
+ DateUtils
+ Display
+ GetConfig
+ Logger
+ OSDep
+ Utils
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Clearcase.pm">Clearcase</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Clearcase/Element.pm">Element</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Clearcase/View.pm">View</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Clearcase/Views.pm">Views</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Clearcase/Vob.pm">Vob</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Clearcase/Vobspm">Vobs</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/DateUtils.pm">DateUtils</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/GetConfig.pm">GetConfig</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Logger.pm">Logger</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/OSDep.pm">OSDep</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Utils.pm">Utils</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this script
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2010, ClearSCM, Inc. All rights reserved.
+
+=cut
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: AddExecute.pl
+# Description: This trigger script simply adds execute permission to an element
+# when it is created in Clearcase
+# Trigger Type: All element
+# Operation: Postop mkelem
+# Author: Andrew@DeFaria.com
+# Created: Fri Mar 12 10:17:44 PST 2004
+# Language: Perl
+# Modifications:
+#
+# (c) Copyright 2004, Andrew@DeFaria.com, all rights reserved
+#
+################################################################################
+use strict;
+use warnings;
+
+my $element = $ENV{CLEARCASE_PN};
+
+system "cleartool protect -chmod +x \"$element\"";
+
+exit 0;
--- /dev/null
+#!/usr/bin/perl
+#################################################################################
+# File: CheckComment.pl,v
+# Revision: 1.1.1.1
+# Description: This trigger checks to insure that the user enters a comment
+# during checkin time.
+# Trigger Type: All element
+# Operation: Preop checkin
+# Author: Andrew@DeFaria.com
+# Created: May 24, 2004
+# Modified: 2007/05/17 07:45:48
+# Language: Perl
+#
+# (c) Copyright 2006, Andrew@DeFaria.com, all rights reserved
+#
+################################################################################
+use strict;
+use warnings;
+
+# Get comment
+my $comment = $ENV {"CLEARCASE_COMMENT"};
+
+# Check if it's empty
+if ($comment eq "") {
+ # Alert user
+ `clearprompt proceed -type error -prompt "You must specify a comment" -mask proceed`;
+ # Exit with non-zero status so checkin aborts
+ exit 1
+} # if
--- /dev/null
+#!/usr/bin/perl -w
+################################################################################
+#
+# File: EvilTwin.pl,v
+# Revision: 1.1.1.1
+# Description: This trigger checks for evil twins. And evil twin can occur when
+# a user checks in an element which matches an element name on
+# some other branch of the directory that is invisible in the
+# current view.
+# Trigger Type: All element
+# Operation: Preop lnname
+# Author: Andrew@DeFaria.com
+# Created: May 24, 2004
+# Modified: 2007/05/17 07:45:48
+# Language: Perl
+#
+# (c) Copyright 2004, Andrew@DeFaria.com, all rights reserved
+#
+################################################################################
+use strict;
+use File::Basename;
+
+# Ensure that the view-private file will get named back on rejection.
+BEGIN {
+ END {
+ rename "$ENV{CLEARCASE_PN}.mkelem", "$ENV{CLEARCASE_PN}"
+ if $? && ! -e "ENV{CLEARCASE_PN}" && -e "$ENV{CLEARCASE_PN}.mkelem";
+ } # END
+} # BEGIN
+
+# Check to see if we are running on Windows
+my $windows = ($^O =~ /MSWin/) ? "yes" : "no";
+
+# Delimeters and null are different on the different OSes
+my $dir_delim = $windows eq "yes" ? "\\" : "/";
+my $dir_delim_e = $windows eq "yes" ? "\\\\" : "\/";
+my $null = $windows eq "yes" ? "NUL" : "/dev/null";
+
+# This is called only if an evil twin is detected. It simply writes
+# out information about the evil twin to a log file. Eventually we
+# will turn this off.
+sub Log {
+ my $msg = shift;
+
+ my $time = localtime;
+ my $user = $ENV {CLEARCASE_USER};
+ my $logpath = $windows eq "yes" ? "\\\\p01ccvob.usa.hp.com\\vobstore\\triggers\\" :
+ "/net/p01ccvob.usa.hp.com/vobstore/triggers/";
+ my $logfile = $logpath . "EvilTwin.log";
+ open LOG, ">>$logfile" or die "Unable to open $logfile";
+
+ print LOG "$time: $user: $msg\n";
+
+ close LOG;
+} # Log
+
+# Get Clearcase Environment variables needed
+my $pname = $ENV {CLEARCASE_PN};
+
+#Log "pname = $pname";
+
+# Get element and parent directory name
+my ($element_name, $parent) = fileparse ($pname);
+#Log "element_name = $element_name";
+#Log "parent = $parent";
+
+# At this point parent will either end with "\.\" on Windows ("/./" on
+# Unix) or a single "\" Windows ("/" on Unix). Windows has a strange
+# situation when the trailing part of parent is = "\". It ends up
+# quoting the double quote and causes the execution of the lsvtree to
+# fail. We must detect this and add on an additional "\".
+if ($parent =~ m/$dir_delim_e\.$dir_delim_e$/) {
+ $parent =~ s/$dir_delim_e\.$dir_delim_e$/$dir_delim_e/;
+} elsif ($parent =~ m/\\$/) {
+ $parent .= $dir_delim;
+} # if
+
+#Log "parent = $parent";
+
+# Look for evil twins
+my $status;
+my $possible_dup;
+
+# Get list of all branches for the parent directory. We will search
+# these for possible evil twins.
+my @parent_dir_branches = `cleartool lsvtree -all -s "$parent"`;
+
+# Fixup parent by removing trailing delimiters
+$parent =~ s/\\\\$/\\/;
+
+foreach (@parent_dir_branches) {
+ chomp;
+ chop if /\r/;
+# Log $_;
+} # foreach
+
+my $evil_twin = 1;
+
+#Log "Checking parent directories";
+foreach (@parent_dir_branches) {
+ chomp;
+
+ $possible_dup = $_ . $dir_delim . $element_name;
+# Log "possible_dup = $possible_dup";
+
+ # View extended pathnames don't work from snapshot views. While
+ # using cleartool ls is slower it also has the benefit of respecting
+ # the case sensitivity of MVFS.
+# Log "Doing ct ls";
+ $status = (system "cleartool ls -s $possible_dup > $null 2>&1") >> 8;
+
+ if ($status eq 0) {
+ # We found something related to $element_name. Now check to see if
+ # this something is a branch name
+# Log "Found something";
+ my $type = `cleartool desc -fmt %m $possible_dup 2>&1`;
+ chomp ($type);
+
+ if ("$type" ne "branch") {
+ # If it's not a branch then we've found an evil twin - set $status
+ # to 1 indicating this and break out.
+# Log "Evil twin found!";
+ $evil_twin = 0;
+ last;
+ } # if
+# } else {
+# Log "status = $status";
+ } # if
+} # foreach
+
+# Exit 0 if the evil twin is not found
+exit 0 if $evil_twin;
+
+# Possible duplicate element is found on invisible branch(es).
+my $prompt;
+my $nl = $windows eq "yes" ? "\\n" : "\n";
+$parent = "." if $parent eq "";
+$prompt = "The element $element_name already exists for the directory \'$parent\'$nl";
+$prompt .= "in another branch as ($possible_dup).$nl$nl";
+$prompt .= "You could either merge the parent directories or create a Clearcase hardline to$nl";
+$prompt .= "that element.$nl$nl";
+$prompt .= "For more information about this condition see:$nl$nl";
+$prompt .= "http://ilmwiki.usa.hp.com/wiki/ClearCase_Evil_Twins$nl$nl";
+$prompt .= "If you feel you really need to perform this action please submit a request$nl";
+$prompt .= "through SourceForge at:$nl$nl";
+$prompt .= "http://plesf01srv.usa.hp.com/sf/tracker/do/listArtifacts/projects.eng_tools_support/tracker.clearcase";
+
+Log "Evil twin detected in $parent. Twin: $possible_dup";
+system ("clearprompt yes_no -mask abort -default abort -newline -prompt \"$prompt\"");
+
+exit 1;
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: Notify.pl
+# Description: This script is a generalized notify trigger. It takes one
+# parameter, a message file. The format of this file is similar
+# to an email message. Environment variables will be substituted.
+#
+# This trigger is typically added, perhaps multiple times with
+# different message files, then attached to elements in the vob
+# as needed. Make the trigger with:
+#
+# cleartool mktrtype -element -postop checkin \
+# -c "<comment>" \
+# -exec "<perl> <path_to_trigger>/Notify.pl \
+# <msg file>" <TRIGGER_NAME>
+#
+# Assumptions: Clearprompt is in the users PATH
+# Author: Andrew@DeFaria.com
+# Created: Tue Mar 12 15:42:55 2002
+# Language: Perl
+# Modifications:
+#
+# (c) Copyright 2004, Andrew@DeFaria.com, all rights reserved
+#
+################################################################################
+use strict;
+
+use File::Spec;
+use Net::SMTP;
+
+my $mailhost = "smtphost";
+
+# This will be set in the BEGIN block but by putting them here the become
+# available for the whole script.
+my (
+ $abs_path,
+ $lib_path,
+ $me,
+ $msgfiles_path,
+ $triggers_path
+);
+
+BEGIN {
+ # Extract relative path and basename from script name.
+ $0 =~ /(.*)[\/\\](.*)/;
+
+ $abs_path = (!defined $1) ? "." : File::Spec->rel2abs ($1);
+ $me = (!defined $2) ? $0 : $2;
+
+ # Setup paths
+ $lib_path = "$abs_path/../lib";
+ $triggers_path = "$abs_path/../triggers";
+ $msgfiles_path = "$abs_path/../msgs";
+
+ # Add the appropriate path to our modules to @INC array.
+ unshift (@INC, "$lib_path");
+} # BEGIN
+
+use TriggerUtils;
+
+# This routine will replace references to environment variables. If an
+# environment variable is not defined then the string <Unknown> is
+# substituted.
+sub ReplaceText {
+ my $line = shift;
+
+ while ($line =~ /\$(\w+)/) {
+ my $var = $1;
+ if ($ENV{$var} eq "") {
+ $line =~ s/\$$var/\<Unknown\>/;
+ } else {
+ my $value = $ENV{$var};
+ $value =~ s/\\/\//g;
+ $line =~ s/\$$var/$value/;
+ } # if
+ } # while
+
+ return $line;
+} # ReplaceText
+
+sub error {
+ my $message = shift;
+
+ clearlogmsg $message;
+
+ exit 1;
+} # error
+
+# First open the message file. If we can't then there's a problem, die!
+my $msgfile = "$msgfiles_path/$ARGV[0]";
+open MSG, $msgfile
+ or error "Unable to open message file:\n\n$msgfile\n\n($!)";
+
+# Suck in file
+my @lines = <MSG>;
+
+# Connect to mail server
+my $smtp = Net::SMTP->new ($mailhost);
+
+error "Unable to open connection to mail host: $mailhost" if $smtp == undef;
+
+# Compose message
+my $data_sent = "F";
+my $from_seen = "F";
+my $to_seen = "F";
+my ($line, $from, $to, @addresses);
+
+foreach $line (@lines) {
+ next if $line =~ /^\#/;
+ next if $line =~ /--/;
+
+ $line = ReplaceText $line;
+
+ if ($line =~ /^From:\s+/) {
+ $_ = $line;
+ $from = $line;
+ s/^From:\s+//;
+ $smtp->mail ($_);
+ $from_seen = "T";
+ next;
+ } # if
+
+ if ($line =~ /^To:\s+/) {
+ $_ = $line;
+ $to = $line;
+ s/^To:\s+//;
+ @addresses = split (/,|;| /);
+ $to_seen = "T";
+ foreach (@addresses) {
+ next if ($_ eq "");
+ $smtp->to ($_);
+ } # foreach
+ next;
+ } # if
+
+ if ($data_sent eq "F") {
+ $smtp->data ();
+ $smtp->datasend ($from);
+ $smtp->datasend ($to);
+ $data_sent = "T";
+ } # if
+
+ if ($from_seen eq "T" && $to_seen eq "T" && $data_sent eq "T") {
+ $smtp->datasend ($line);
+ } else {
+ clearlogmsg "Message file ($ARGV[0]) missing From and/or To!";
+ exit 1;
+ } # if
+} # foreach
+
+$smtp->dataend ();
+$smtp->quit;
+
+exit 0;
--- /dev/null
+From: Vobadm <vobadm@Ameriquest.net>\r
+To: <***ADD EMAIL ADDRESSES HERE***>\r
+Subject: $CLEARCASE_OP_KIND notification: $CLEARCASE_PN\r
+--\r
+This is a notification that a $CLEARCASE_OP_KIND has occurred:\r
+\r
+Element: $CLEARCASE_PN\r
+Branch: $CLEARCASE_BRTYPE\r
+Operation: $CLEARCASE_OP_KIND\r
+User: $CLEARCASE_USER\r
+View: $CLEARCASE_VIEW_TAG\r
+Comments: \r
+\r
+$CLEARCASE_COMMENT\r
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: NotifyTrigger.pl,v
+# Revision: 1.1.1.1
+# Description: This script is a generalized notify trigger. It takes one
+# parameter, a message file. The format of this file is similar
+# to an email message. Environment variables will be substituted.
+#
+# This trigger is typically added, perhaps multiple times with
+# different message files, then attached to elements in the vob
+# as needed. Make the trigger with:
+#
+# cleartool mktrtype -element -postop checkin \
+# -c "<comment>" \
+# -exec "<perl> <path_to_trigger>/NotifyTrigger.pl \
+# <msg file>" <TRIGGER_NAME>
+#
+# Assumptions: Clearprompt is in the users PATH
+# Author: Andrew@DeFaria.com
+# Created: Tue Mar 12 15:42:55 2002
+# Modified: 2007/05/17 07:45:48
+# Language: Perl
+#
+# (c) Copyright 2004, Andrew@DeFaria.com, all rights reserved
+#
+################################################################################
+use strict;
+use warnings;
+
+use File::Spec;
+use Net::SMTP;
+
+# Define mailhost here (or set in the environment)
+my $mailhost = defined $ENV {MAILHOST} ? $ENV {MAILHOST} : undef;
+
+# This will be set in the BEGIN block but by putting them here the become
+# available for the whole script.
+my (
+ $abs_path,
+ $lib_path,
+ $log_path,
+ $me,
+ $triggers_path
+);
+
+BEGIN {
+ # Extract relative path and basename from script name.
+ $0 =~ /(.*)[\/\\](.*)/;
+
+ $abs_path = (!defined $1) ? "." : File::Spec->rel2abs ($1);
+ $me = (!defined $2) ? $0 : $2;
+
+ # Setup paths
+ $lib_path = "$abs_path/../lib";
+ $log_path = "$abs_path/../log";
+ $triggers_path = "$abs_path/../triggers";
+
+ # Add the appropriate path to our modules to @INC array.
+ unshift (@INC, "$lib_path");
+} # BEGIN
+
+use TriggerUtils;
+
+# This routine will replace references to environment variables. If an
+# environment variable is not defined then the string <Unknown> is
+# substituted.
+sub ReplaceText {
+ my $line = shift;
+
+ while ($line =~ /\$(\w+)/) {
+ my $var = $1;
+ if ($ENV{$var} eq "") {
+ $line =~ s/\$$var/\<Unknown\>/;
+ } else {
+ my $value = $ENV{$var};
+ $value =~ s/\\/\//g;
+ $line =~ s/\$$var/$value/;
+ } # if
+ } # while
+
+ return $line;
+} # ReplaceText
+
+sub error {
+ my $message = shift;
+
+ clearlogmsg $message;
+
+ exit 1;
+} # error
+
+# First open the message file. If we can't then there's a problem, die!
+my $msgfile = "$triggers_path/$ARGV[0]";
+open MSG, $msgfile
+ or error "Unable to open message file:\n\n$msgfile\n\n($!)";
+
+# Suck in file
+my @lines = <MSG>;
+
+# Connect to mail server
+error "Mailhost is not defined!" if !defined $mailhost;
+my $smtp = Net::SMTP->new ($mailhost);
+
+error "Unable to open connection to mail host: $mailhost" if $smtp == undef;
+
+# Compose message
+my $data_sent = "F";
+my $from_seen = "F";
+my $to_seen = "F";
+my ($line, $from, $to, @addresses);
+
+foreach $line (@lines) {
+ next if $line =~ /^\#/;
+ next if $line =~ /--/;
+
+ $line = ReplaceText $line;
+
+ if ($line =~ /^From:\s+/) {
+ $_ = $line;
+ $from = $line;
+ s/^From:\s+//;
+ $smtp->mail ($_);
+ $from_seen = "T";
+ next;
+ } # if
+
+ if ($line =~ /^To:\s+/) {
+ $_ = $line;
+ $to = $line;
+ s/^To:\s+//;
+ @addresses = split (/,|;| /);
+ $to_seen = "T";
+ foreach (@addresses) {
+ next if ($_ eq "");
+ $smtp->to ($_);
+ } # foreach
+ next;
+ } # if
+
+ if ($data_sent eq "F") {
+ $smtp->data ();
+ $smtp->datasend ($from);
+ $smtp->datasend ($to);
+ $data_sent = "T";
+ } # if
+
+ if ($from_seen eq "T" && $to_seen eq "T" && $data_sent eq "T") {
+ $smtp->datasend ($line);
+ } else {
+ clearlogmsg "Message file ($ARGV[0]) missing From and/or To!";
+ exit 1;
+ } # if
+} # foreach
+
+$smtp->dataend ();
+$smtp->quit;
+
+exit 0;
--- /dev/null
+################################################################################
+#
+# File: Protect.pl,v
+# Revision: 1.1.1.1
+# Description: When new elements are created in the VOB change the elements
+# ownership to the owner of the VOB and change element permissions
+# to appropiate for element_type.
+#
+# NOTE: If a particular file_type is not implemented in
+# your VOB then comment it out. Unspecified file_types
+# will have origional permissions, but will have
+# ownership changed.
+# Assumptions: Clearprompt is in the users PATH
+# Author: Andrew@DeFaria.com
+# Created: April 20, 2003
+# Modified: 2007/05/17 07:45:48
+# Language: Perl
+#
+################################################################################
+use strict;
+use warnings;
+
+# What do we set the owner and group to?
+my $owner = "vobadm";
+my $group = "ccadmin";
+
+# Get CLEARCASE_PN
+my $pname = $ENV {CLEARCASE_PN};
+
+# Let's get the real owner from the real output of describe
+my @output = `cleartool describe vob:$pname`;
+
+foreach (@output) {
+ if (/owner\s*\w*\\(.*)/) {
+ $owner = $1;
+ chop $owner if $owner =~ /\r/; # any carriage return
+ last;
+ } # if
+} # foreach
+
+# Let's get the real group from the real output of describe
+foreach (@output) {
+ if (/group\s*\w*\\(.*)/) {
+ $group = $1;
+ chop $group if $group =~ /\r/; # any carriage return
+ last;
+ } # if
+} # foreach
+
+# Get what element type we are dealing with
+my $eltype = $ENV {CLEARCASE_ELTYPE};
+
+if (($eltype eq "directory") ||
+ ($eltype =~ /.*script/) ||
+ ($eltype =~ /.*program/)) {
+ # All element types that are known to be 775 should be placed here.
+ `cleartool protect -chmod 775 -chown $owner -chgrp $group $pname`;
+} elsif (($eltype eq "makefile") ||
+ ($eltype =~ /.*include/) ||
+ ($eltype =~ /.*source/)) {
+ # All element types that are known to be 664 should be placed here.
+ `cleartool protect -chmod 664 -chown $owner -chgrp $group $pname`;
+} elsif ($eltype eq "report") {
+ # All element types that are known to be 644 should be placed here.
+ `cleartool protect -chmod 644 -chown $owner -chgrp $group $pname`;
+} else {
+ # All other element types should just have the ownership changed.
+ `cleartool protect -chown $owner -chgrp $group $pname`;
+} # if
+
+exit 0
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: RemoveEmptyBranch.pl,v
+# Revision: 1.1.1.1
+# Description: This trigger script is remove empty branches. If a branch has
+# no elements (except the 0 element of course) after an uncheckout
+# remove it and the branch.
+# Trigger Type: All element
+# Operation: Postop rmbranch, uncheckout
+# Author: Andrew@DeFaria.com
+# Created: Fri Mar 12 10:17:44 PST 2004
+# Modified: 2007/05/17 07:45:48
+# Language: Perl
+#
+# (c) Copyright 2004, ClearSCM, Inc., all rights reserved
+#
+################################################################################
+use strict;
+use warnings;
+
+use Carp;
+
+my $debug = $ENV{TRIGGER_DEBUG};
+my $windows = ($^O || $ENV{OS}) =~ /MSWin32|Windows_NT/i ? "yes" : "no";
+my $SEPARATOR = $windows eq "yes" ? "\\" : "/";
+my $null = $windows eq "yes" ? "NUL" : "/dev/null";
+my $trigger_file;
+
+sub InitDebug {
+ my $tmpdir = $ENV{TMP};
+ my $trigger_debug_log = "$tmpdir/trigger_debug.log";
+
+ open my $debugLog, '>>', $trigger_debug_log
+ or croak "Unable to open $trigger_debug_log";
+
+ return $debugLog
+} # InitDebug
+
+sub debug {
+ my ($msg) = @_;
+
+ return if !defined $debug;
+
+ $trigger_file = InitDebug if !defined $trigger_file;
+
+ print $trigger_file "$msg\n";
+
+ return;
+} # debug
+
+# The following environment variables are set by Clearcase when this
+# trigger is called
+my $xname = $ENV{CLEARCASE_XPN};
+my $xn_sfx = $ENV{CLEARCASE_XN_SFX};
+my $opkind = $ENV{CLEARCASE_OP_KIND};
+my $brtype = $ENV{CLEARCASE_BRTYPE};
+my $view_type = $ENV{CLEARCASE_VIEW_KIND};
+
+debug "RM_EMPTY_BRANCH Trigger:";
+debug "CLEARCASE_XPN = $xname";
+debug "CLEARCASE_XN_SFX = $xn_sfx";
+debug "CLEARCASE_OP_KIND = $opkind";
+debug "CLEARCASE_BRTYPE = $brtype";
+debug "CLEARCASE_VIEW_KIND = $view_type";
+
+$xname =~ s/\\/\//g if $windows eq "yes";
+
+# For uncheckout, if the remaining version is not 0 then we are done -
+# the most common case...
+exit 0 if ($opkind eq "uncheckout" && $xname !~ m/\/0$/);
+
+my $branch = $xname;
+
+if ($opkind eq "uncheckout") {
+ # Remove the last component
+ $branch =~ s/\/[^\/]*$//;
+} # if
+
+# Don't try to remove the /main branch
+exit 0 if $branch =~ m/$xn_sfx\/main$/;
+
+# Check if there are other versions, branches, labels or checked out versions
+# on this branch. If so don't do anything.
+if ($view_type eq "dynamic") {
+ opendir (DIR, $branch);
+ my @entries = readdir (DIR);
+ closedir (DIR);
+
+ # In an empty branch there are four things: ".", "..", "0" an d"LATEST".
+ # If there are more then it isn't an empty branch
+ exit 0 if (scalar (@entries) != 4);
+} else {
+ # Snapshot views.
+ my ($pname, $brpath) = split ($xn_sfx, $branch);
+
+ # The rmbranch will not reload the element. This shows as "special
+ # selection, deleted version" in snapshot views This cleans that up.
+ if ($opkind eq "rmbranch") {
+ system "cleartool update -log $null \"$pname\"" if ($opkind eq "rmbranch");
+ exit 0; # Nothing else to do here...
+ } # if
+
+ my @vtree = `cleartool lsvtree -branch $brpath \"$pname\"`;
+ my $latest;
+ chomp ($latest = pop (@vtree));
+ $latest =~ tr/\\/\// if $windows eq "yes";
+
+ exit 0 unless $latest =~ m/$brpath\/0$/;
+} # if
+
+# Remove the branch!
+debug "Removing empty branch $branch";
+system "cleartool rmbranch -force -nc \"$branch\"";
+
+exit 0;
--- /dev/null
+ls
+quit
+ls
+exit
+lsa
+ls
+quit
--- /dev/null
+.project
+.cvsignore
+.clearexec_hist
+.perldb.hist
--- /dev/null
+
+my $offset = 0;
+my $savout = select($DB::OUT);
+dumpvar_epic::dump_lexical_vars($offset);
+select($savout);
+};
+
+;{
+do 'dumpvar_epic.pm' unless defined &dumpvar_epic::dump_lexical_vars;
+
+my $offset = 0;
+my $varexpr = <<'EOT';
+$h->{'%parms'}
+EOT
+my $subref = \&dumpvar_epic::dump_hash_expr;
+my $savout = select($DB::OUT);
+my $savbuf = $|;
+$| = 0;
+$subref->($offset, $varexpr);
+$| = $savbuf;
+print "";
+select($savout);
+};
+
+;{
+do 'dumpvar_epic.pm' unless defined &dumpvar_epic::dump_lexical_vars;
+
+my $offset = 0;
+my $varexpr = <<'EOT';
+$h->{'@months'}
+EOT
+my $subref = \&dumpvar_epic::dump_array_expr;
+my $savout = select($DB::OUT);
+my $savbuf = $|;
+$| = 0;
+$subref->($offset, $varexpr);
+$| = $savbuf;
+print "";
+select($savout);
+};
+
+;{
+do 'dumpvar_epic.pm' unless defined &dumpvar_epic::dump_lexical_vars;
+
+my $offset = 0;
+my $varexpr = <<'EOT';
+$h->{'@validKeys'}
+EOT
+my $subref = \&dumpvar_epic::dump_array_expr;
+my $savout = select($DB::OUT);
+my $savbuf = $|;
+$| = 0;
+$subref->($offset, $varexpr);
+$| = $savbuf;
+print "";
+select($savout);
+};
+
+b 166
+x $system
+x $status
+x @output
+f Clearexec
+b 345
+x $?
+x $!
+c snapshotsystem
+/snapshot
+c 82
+x $status
+x @output
+x $output[0]
+x $1
+x \%load
+x @output
+v 94
+c 94
+x $cmd
+x $restart
+x $status
+x @output
+$cmd .= "| grep -v 'grep -i \'$name\'"
+x $cmd
+($status, @output) = Execute $cmd
+x $cmd
+$cmd = 'ps -ef | grep -i \'mediamallserver\' | grep -v \'grep -i \"mediamallserver\"\''
+x $cmd
+$cmd = 'ps -ef | grep -i \'mediamallserver\' | grep -v \'grep -i \"mediamallserver\"\''
+($status, @output) = Execute $cmd
+x $status
+x @output
+$cmd = 'ps -eWf | grep -i \'mediamallserver\' | grep -v \'grep -i \"mediamallserver\"\''
+($status, @output) = Execute $cmd
+x $cmd
+ls
+$status = 1
+x $status
+x $restart
+x $status
+x @output
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<projectDescription>
+ <name>clearadm</name>
+ <comment></comment>
+ <projects>
+ </projects>
+ <buildSpec>
+ <buildCommand>
+ <name>org.epic.perleditor.perlbuilder</name>
+ <arguments>
+ </arguments>
+ </buildCommand>
+ </buildSpec>
+ <natures>
+ <nature>org.epic.perleditor.perlnature</nature>
+ </natures>
+</projectDescription>
--- /dev/null
+CLEARADM:
+
+Clearadm is a set of scripts and a web app designed to discover and monitor
+systems in your infrastructure with an eye towards servers as well as Clearcase.
+
+DEPENDENCIES:
+
+In order for graphics to work you need to install GD for Perl (libgd-graph-perl
+and I also installed libgd-graph3d-perl) as well as GD::Graph from cpan.
+
+While Clearadm is designed to monitor Unix, Linux and Windows machines, it
+requires the installation of Cygwin and Cygwin's Perl package to run on Windows.
+Clearagent also requires Cygwin and Cygwin's Perl.
+
+INSTALLATION
+
+SERVER Selection
+
+Clearadm is a distributed system. Various components can be set up to run on
+different servers. For example, the database server machine need not be the same
+machine that the web component of Clearadm runs. Additionally all systems report
+status through clearagent.pl by running a small agent daemon. Finally
+cleartasks.pl performs scheduled tasks and it can run on a separate server.
+Generally you only use one or two servers but you have the option to distribute
+the load.
+
+CLEARADM Database
+
+Clearadm uses a MySQL database to store information about your infrastructure.
+Unpack the clearadm.tar.gz file (normally rooted in /opt/clearscm) and set up
+the MySQL database by executing mysql then sourcing:
+
+ clearadm.sql -- Creates the database
+ users.sql -- Sets up the database users
+ load.sql -- Loads up some predefined tasks and schedules
+
+CLEARAGENT Setup
+
+Clearagent: This is a little agent program that receives requests from other
+hosts and executes them on the host running clearagent. As such you want to have
+clearagent.pl running all the time. Normally it backgrounds itself and it is
+multithreaded so that it can handle multiple requests efficiently.
+
+Clearagent components have been separated into the clearagent.tar.gz file. This
+allows you to install only the clearagent portion on your servers.
+
+Under Unix/Linux hosts there is a Sys/V init.d script under etc/init.d.
+Additionally for security concerns clearagent is run under a plain user named
+clearagent. In order to set this up on a Unix/Linux host do the following as
+root:
+
+ $ export CLEARADM=/opt/clearscm/clearadm
+ $ useradd -Mr clearagent
+ $ chmod 777 $CLEARADM/var $CLEARADM/var/run $CLEARADM/log
+ $ ln -s $CLEARADM/etc/init.d/clearagent /etc/init.d/clearagent
+ $ /etc/init.d/clearagent start
+
+You can test to see if clearagent is running properly by executing:
+
+ $ $CLEARADM/clearexec.pl -host localhost
+ clearexec:hostname
+ <localhost>
+ clearexec:exit
+ $
+
+ For Windows machines, assuming you have Cygwin installed, create a service for
+ clearagent:
+
+ $ cygrunsrv -I clearagent -p C:/Cygwin/bin/perl \
+ > -a '/opt/clearscm/clearadm/clearagent.pl -nodaemon'
+ $ net start clearagent
+
+ Note that -nodaemon is used but the Windows service will handle the
+ backgrounding of clearagent. Testing clearagent is the same as for Unix/Linux.
+
+CLEARADM Discovery
+
+You can use the discover.pl script to discover machines on the network and have
+them added to the clearadm database. However, until you set up clearagent on
+those machines, monitoring of these systems will be limited.
+
+CLEARADM Web
+
+Clearadm Web component should be running on one server in your subnet. It is
+designed to work with Apache 2 Web servers. Symlink
+$CLEARADM/etc/conf.d/clearadm -> /etc/apache2/conf.d and restart Apache
+
+CLEARADM Tasks
+
+In additional to setting up the database, web server and installing agents on
+the various machines you wish to monitor, you should run cleartasks.pl to
+perform the scheduled tasks on a periodic bases. Clearadm comes with some
+predefined tasks. You can add/develop your own. Simply run cleartasks.pl and it
+will background itself, performing tasks when necessary (Should we make an
+init.d script for this? My worry is that if that gets configured on more than
+one machine...)
+
+CLEARADM Clearcase Reporting (Need to fill this out better)
+
+Clearadm can show you where your views and vobs reside as well as provide useful
+functionality like a view aging report, etc. In order to collect such
+information Clearadm needs to periodically collect information about those
+Clearcase objects. Predefined scheduled tasks and alerts are set up to do this
+but you must do some configuration yourself to tell Clearadm where your
+Clearcase objects reside. For example, you need to tell it where your registry
+server(s) are, what regions you wish to report on as well as set other
+configuration settings as to how long to age views and vobs, etc.
+
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: alertlog.cgi,v $
+
+Display the alert log
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.9 $
+
+=item Created:
+
+Mon Oct 25 11:10:47 PDT 2008
+
+=item Modified:
+
+$Date: 2011/01/29 23:33:04 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage alertlog.cgi: [-u|sage] [-ve|rbose] [-d|ebug]
+
+ Where:
+ -u|sage: Displays usage
+ -ve|rbose: Be verbose
+ -d|ebug: Output debug messages
+
+=head2 DESCRIPTION
+
+This script displays the alert log
+
+=cut
+
+use strict;
+use warnings;
+
+use FindBin;
+use Getopt::Long;
+use CGI qw (:standard :cgi-lib *table start_Tr end_Tr);
+use CGI::Carp 'fatalsToBrowser';
+
+use lib "$FindBin::Bin/lib", "$FindBin::Bin/../lib";
+
+use Clearadm;
+use ClearadmWeb;
+use Display;
+use Utils;
+
+my $VERSION = '$Revision: 1.9 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+my $clearadm;
+
+my %opts = Vars;
+
+$opts{start} ||= 0;
+$opts{page} ||= 10;
+
+# Main
+GetOptions (
+ usage => sub { Usage },
+ verbose => sub { set_verbose },
+ debug => sub { set_debug },
+) or Usage 'Invalid parameter';
+
+undef $opts{alert}
+ if $opts{alert} and $opts{alert} eq 'All';
+undef $opts{system}
+ if $opts{system} and $opts{system} eq 'All';
+undef $opts{notification}
+ if $opts{notification} and $opts{notification} eq 'All';
+
+# Announce ourselves
+verbose "$FindBin::Script v$VERSION";
+
+$clearadm = Clearadm->new;
+
+my $title = 'Alert Log';
+
+heading $title;
+
+display h1 {class => 'center'}, $title;
+
+displayAlertlog (%opts);
+
+footing;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<CGI>
+
+L<CGI::Carp|CGI::Carp>
+
+L<FindBin>
+
+L<Getopt::Long|Getopt::Long>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ Clearadm
+ ClearadmWeb
+ Display
+ Utils
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/Clearadm.pm">Clearadm</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/ClearadmWeb.pm">ClearadmWeb</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Utils.pm">Utils</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this script
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2010, ClearSCM, Inc. All rights reserved.
+
+=cut
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: alerts.cgi,v $
+
+Display alerts
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.3 $
+
+=item Created:
+
+Mon Oct 25 11:10:47 PDT 2008
+
+=item Modified:
+
+$Date: 2011/01/20 01:19:24 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage alerts.cgi: [-u|sage] [-ve|rbose] [-d|ebug]
+
+ Where:
+ -u|sage: Displays usage
+ -ve|rbose: Be verbose
+ -d|ebug: Output debug messages
+
+=head2 DESCRIPTION
+
+This script displays alerts
+
+=cut
+
+use strict;
+use warnings;
+
+use FindBin;
+use Getopt::Long;
+use CGI qw (:standard :cgi-lib *table start_Tr end_Tr);
+use CGI::Carp 'fatalsToBrowser';
+
+use lib "$FindBin::Bin/lib", "$FindBin::Bin/../lib";
+
+use Clearadm;
+use ClearadmWeb;
+use Display;
+use Utils;
+
+my $VERSION = '$Revision: 1.3 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+my $clearadm;
+
+my %opts = Vars;
+
+# Main
+GetOptions (
+ usage => sub { Usage },
+ verbose => sub { set_verbose },
+ debug => sub { set_debug },
+) or Usage 'Invalid parameter';
+
+# Announce ourselves
+verbose "$FindBin::Script v$VERSION";
+
+$clearadm = Clearadm->new;
+
+my $title = $opts{alert}
+ ? "Alerts matching $opts{alert}"
+ : 'Alerts';
+
+heading $title;
+
+display h1 {class => 'center'}, $title;
+
+displayAlert $opts{alert};
+
+footing;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<CGI>
+
+L<CGI::Carp|CGI::Carp>
+
+L<FindBin>
+
+L<Getopt::Long|Getopt::Long>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ Clearadm
+ ClearadmWeb
+ Display
+ Utils
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/Clearadm.pm">Clearadm</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/ClearadmWeb.pm">ClearadmWeb</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Utils.pm">Utils</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this script
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2010, ClearSCM, Inc. All rights reserved.
+
+=cut
\ No newline at end of file
--- /dev/null
+/*******************************************************************************
+*
+* File: $RCSfile: clearadm.css,v $
+* Revision: $Revision: 1.20 $
+* Description: Cascading Style Sheet definitions for Clearadm
+* Author: Andrew@ClearSCM.com
+* Created: Sun Jan 16 11:13:19 EST 2011
+* Modified: $Date: 2011/01/28 21:28:40 $
+* Language: Cascading Style Sheet
+*
+* (c) Copyright 2010, Andrew@DeFaria.com, all rights reserved.
+*
+*******************************************************************************/
+body {
+ background-color:white;
+ font-family:veranda, times;
+ font-size:14px;
+ margin:0px;
+ background-image:url('/clearadm/banner.jpg');
+ background-repeat:repeat-x;
+ margin-bottom:100px;
+}
+
+/* Element classes */
+h1.title {
+ color:white;
+ text-align:center;
+ height:70px;
+}
+
+font.unknown {
+ color:#ddd;
+}
+
+font.dim {
+ color:#999;
+}
+
+p, h2 {
+ margin:10px;
+}
+
+/* Stylings for page div */
+.page a:link {
+ color:blue;
+ text-decoration:none;
+}
+
+.page a:visited {
+ color:blue;
+}
+
+.page a:hover {
+ color:red;
+}
+
+.dataCenteredAlert a:link {
+ color:red;
+ font-size:18px;
+}
+.dataCenteredAlert a:visited {
+ color:red;
+ font-size:18px;
+}
+
+/* Classes for control boxes */
+.filesystemControls {
+ background-color:#fef5d8;
+ text-align:right;
+ padding:0px;
+ border-right:1px solid black;
+ border-left:1px solid black;
+ border-bottom:1px solid black;
+}
+
+.controls {
+ background-color:#fef5d8;
+ text-align:right;
+ padding:0px;
+ border:1px solid black;
+}
+
+.filter {
+ background-color:#fef5d8;
+}
+
+/* Set the border to have a 3D effect for the chart image */
+img.chart {
+ border-top:2px solid #eee;
+ border-left:2px solid #eee;
+ border-right:2px solid black;
+ border-bottom:2px solid black;
+}
+
+/* Stylings for table elements */
+table {
+ background-color:black;
+ padding:0px;
+ margin-left:auto;
+ margin-right:auto;
+}
+
+tr.oldview {
+ background-color:#eeeeee;
+}
+
+tr.view {
+ background-color:white;
+}
+
+td.center {
+ text-align:center;
+}
+
+td.right {
+ text-align:right;
+}
+
+th, td {
+ padding:4px;
+}
+
+th.label {
+ text-align:right;
+ background-color:#fef5d8;
+}
+
+th.labelCentered {
+ text-align:center;
+ background-color:#fef5d8;
+}
+
+td.data {
+ background-color:white;
+}
+
+td.dataTop {
+ background-color:white;
+ vertical-align:top;
+}
+
+td.dataAlert {
+ background-color:white;
+ color:red;
+ font-weight:bold;
+}
+
+td.dataAlertTop {
+ background-color:white;
+ color:red;
+ font-weight:bold;
+ vertical-align:top;
+}
+
+td.dataRightAlert {
+ background-color:white;
+ color:red;
+ font-weight:bold;
+ text-align:right;
+}
+
+td.dataCenteredAlert {
+ background-color:white;
+ color:red;
+ font-weight:bold;
+ text-align:center;
+}
+
+td.dataRightAlertTop {
+ background-color:white;
+ color:red;
+ font-weight:bold;
+ text-align:right;
+ vertical-align:top;
+}
+
+td.dataCentered {
+ text-align:center;
+ background-color:white;
+}
+
+td.dataCenteredTop {
+ text-align:center;
+ background-color:white;
+ vertical-align:top;
+}
+
+td.dataAlertCentered {
+ text-align:center;
+ background-color:white;
+ color:red;
+ font-weight:bold;
+}
+
+td.dataAlertCenteredTop {
+ text-align:center;
+ background-color:white;
+ color:red;
+ font-weight:bold;
+ vertical-align:top;
+}
+
+td.dataRight {
+ text-align:right;
+ background-color:white;
+}
+
+td.dataRightTop {
+ text-align:right;
+ background-color:white;
+ vertical-align:top;
+}
+
+td.dataAlertRight {
+ text-align:right;
+ background-color:white;
+ color:red;
+ font-weight:bold;
+}
+
+td.dataAlertRightTop {
+ text-align:right;
+ background-color:white;
+ color:red;
+ font-weight:bold;
+ vertical-align:top;
+}
+
+/* Classes for viewager */
+.dynamic {
+ color:red;
+}
+
+.snapshot {
+ color:green;
+}
+
+.web {
+ color:orange;
+}
+
+.caption {
+ background-color:white;
+}
+
+/* General classes */
+.label {
+ font-weight:bold;
+}
+
+.heading {
+ background-color:#fef5d8;
+}
+
+.center {
+ text-align:center;
+}
+
+.error {
+ color:red;
+ font-weight:bold;
+}
+
+.inputfield {
+ background:#ece9d8;
+ font-family:arial, veranda, times;
+ font-size:14px;
+}
+
+.inputfieldRight {
+ background:#ece9d8;
+ font-family:arial, veranda, times;
+ font-size:14px;
+ text-align:right;
+}
+
+.dropdown {
+ background-color:#ece9d8;
+ font-family:arial, veranda, times;
+ font-size:14px;
+}
+
+/* Copyright block */
+.copyright {
+ border-bottom:1px dotted #ccc;
+ border-top:1px dotted #ccc;
+ color:#999;
+ font-family:verdana, arial, sans-serif;
+ font-size:10px;
+ margin-top:5px;
+ text-align:center;
+ width:auto;
+}
+
+.copyright a:link, a:visited {
+ color:#666;
+ font-weight:bold;
+ text-decoration:none;
+}
+
+.copyright a:hover {
+ color:#333;
+}
\ No newline at end of file
--- /dev/null
+////////////////////////////////////////////////////////////////////////////////
+//
+// File: $RCSfile: clearadm.js,v $
+// Revision: $Revision: 1.8 $
+// Description: Javascript routines for Clearadm
+// Author: Andrew@ClearSCM.com
+// Created: Wed Dec 29 12:36:47 EST 2010
+// Modified: $Date: 2011/01/21 01:00:09 $
+// Language: JavaScript
+//
+// (c) Copyright 2010, ClearSCM, Inc., all rights reserved.
+//
+////////////////////////////////////////////////////////////////////////////////
+function getXMLHTTP () {
+ try {
+ return new XMLHttpRequest ();
+ } catch (e) {
+ try {
+ return new ActiveXObject ('Microsoft.XMLHTTP');
+ } catch (e) {
+ try {
+ return new ActiveXObject ('Msxml2.XMLHTTP');
+ } catch (e) {
+ return false;
+ } // try
+ } // try
+ } // try
+} // getXMLHTTP
+
+function updateTimestamp (system, elementID, filesystem) {
+ var request = getXMLHTTP ();
+ var script = 'getTimestamp.cgi?system=' + system + '&elementID=' + elementID;
+
+ var scaling = document.getElementById ('scalingFactor').value;
+
+ if (scaling) {
+ script += '&scaling=' + scaling;
+ } // if
+
+ if (filesystem) {
+ script += '&filesystem=' + filesystem;
+ } // if
+
+ if (request) {
+ request.onreadystatechange = function () {
+ if (request.readyState == 4) {
+ if (request.status == 200) {
+ document.getElementById (elementID).innerHTML
+ = request.responseText;
+ } // if
+ } // if
+ } // function
+
+ request.open ('get', script, true);
+ request.send (null);
+ } else {
+ alert ('Unable to create XMLHTTP Request object');
+ } // if
+} // updateTimestamp
+
+function updateSystem (system) {
+ updateTimestamp (system, 'startTimestamp');
+ updateTimestamp (system, 'endTimestamp');
+} // updateSystem
+
+function updateSystemLink (system) {
+ document.getElementById ('systemLink').innerHTML
+ = '<a href="systemdetails.cgi?system=' + system + '">System</a>';
+
+ updateTimestamp (system, 'startTimestamp');
+ updateTimestamp (system, 'endTimestamp');
+} // updateSystemLink
+
+function updateFilesystems (system) {
+ var request = getXMLHTTP ();
+
+ if (request) {
+ request.onreadystatechange = function () {
+ if (request.readyState == 4) {
+ if (request.status == 200) {
+ document.getElementById ('filesystems').innerHTML
+ = request.responseText;
+ } // if
+ } // if
+ } // function
+
+ request.open ('GET', 'getFilesystems.cgi?system=' + system, true);
+ request.send (null);
+ } else {
+ alert ('Unable to create XMLHTTP Request object');
+ } // if
+} // updateFilesystems
+
+function updateFilesystem (system, filesystem) {
+ updateTimestamp (system, 'startTimestamp', filesystem);
+ updateTimestamp (system, 'endTimestamp', filesystem);
+} // updateFilesystem
+
+function trimSpaces (str) {
+ return str.replace (/^\s+|\s+$/g, '');
+} // trimSpaces
+
+function validEmailAddress (email) {
+ var emailPattern = /^[a-zA-Z0-9._-]+@[a-zA-Z0-9.-]+\.[a-zA-Z]{2,4}$/;
+
+ return emailPattern.test (email);
+} // validEmailAddress
+
+function validateAlert (alertrec) {
+ with (alertrec) {
+ if (name.value == '') {
+ alert ("You must specify the alert's name");
+ name.focus ();
+ return false;
+ } // if
+
+ if (who.value) {
+ if (!validEmailAddress (alertrec.who.value)) {
+ alert ('That email address is invalid!\n'
+ + 'Must be <username>@<domainname>\n'
+ + 'For example: Andrew@ClearSCM.com');
+ return false;
+ } // if
+ } // if
+ } // with
+} // validateAlert
+
+function validateNotification (notification) {
+ with (notification) {
+ if (name.value == '') {
+ alert ("You must specify the notification's name");
+ name.focus ();
+ return false;
+ } // if
+
+ if (cond.value == '') {
+ alert ('You must specify a condition');
+ cond.focus ();
+ return false;
+ } // if
+ } // with
+} // validateNotification
+
+function validateSchedule (schedule) {
+ with (schedule) {
+ if (name.value == '') {
+ alert ("You must specify the schedule's name");
+ name.focus;
+ return false;
+ } // if
+
+ if (isNaN (nbr.value)) {
+ alert ('Frequency is not a number');
+ nbr.focus;
+ return false;
+ } else if (nbr.value < 1 || nbr.value > 999) {
+ alert ('Frequency must be a positive number between 1-999');
+ nbr.focus;
+ return false;
+ } // if
+ } // with
+} // validateSchedule
+
+function validateTask (task) {
+ with (task) {
+ if (name.value == '') {
+ alert ("You must specify the task's name");
+ name.focus;
+ return false;
+ } // if
+ } // with
+} // validateTask
+
+function validateSystem (system) {
+ with (system) {
+ name.value = trimSpaces (name.value);
+
+ if (name.value == '') {
+ alert ("You must specify the system's name");
+ name.focus ();
+ return false;
+ } // if
+
+ admin.value = trimSpaces (admin.value);
+
+ if (admin.value == '') {
+ alert ("You must specify the admin's name");
+ admin.focus ();
+ return false;
+ } // if
+
+ if (isNaN (port.value)) {
+ alert ('Port is not a number');
+ port.focus;
+ return false;
+ } else if (port.value < 1 || port.value > 65535) {
+ alert ('Port must be a positive number between 1-65535');
+ port.focus;
+ return false;
+ } // if
+
+ if (isNaN (loadavgThreshold.value)) {
+ alert ('Loadavg Threshold is not a number');
+ loadavgThreshold.focus;
+ return false;
+ } else if (loadavgThreshold.value < 0 || loadavgThreshold.value > 99.99) {
+ alert ('Loadavg Threshold must be a positive number between 0 - 99.99');
+ loadavgThreshold.focus;
+ return false;
+ } // if
+
+ email.value = trimSpaces (email.value);
+
+ if (email.value == '') {
+ alert ("You must specify the admin's email");
+ email.focus ();
+ return false;
+ } else {
+ if (!validEmailAddress (email.value)) {
+ alert ('That email address is invalid!\n'
+ + 'Must be <username>@<domainname>\n'
+ + 'For example: Andrew@ClearSCM.com');
+ return false;
+ } // if
+ } // if
+ } // with
+} // validateSystem
+
+function AreYouSure (message) {
+ return window.confirm (message);
+} // AreYouSure
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: clearadmscrub.pl,v $
+
+Scrub Clearadm records
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.9 $
+
+=item Created:
+
+Sun Jan 2 19:40:28 EST 2011
+
+=item Modified:
+
+$Date: 2012/11/09 06:45:36 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage clearadmscrub.pl: [-u|sage] [-ve|rbose] [-deb|ug]
+
+ Where:
+ -u|sage: Displays usage
+
+ -ve|rbose: Be verbose
+ -deb|ug: Output debug messages
+
+=head1 DESCRIPTION
+
+This script will scrub all old records in the Clearadm database
+
+=cut
+
+use strict;
+use warnings;
+
+use FindBin;
+use Getopt::Long;
+
+use lib "$FindBin::Bin/lib", "$FindBin::Bin/../lib";
+
+use Clearadm;
+use DateUtils;
+use Display;
+use TimeUtils;
+use Utils;
+
+my $VERSION = '$Revision: 1.9 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+my $clearadm = Clearadm->new;
+
+my ($host, $fs);
+
+# Main
+GetOptions (
+ 'usage' => sub { Usage },
+ 'verbose' => sub { set_verbose },
+ 'debug' => sub { set_debug },
+) or Usage "Invalid parameter";
+
+Usage 'Extraneous options: ' . join ' ', @ARGV
+ if @ARGV;
+
+# Announce ourselves
+verbose "$FindBin::Script V$VERSION";
+
+my ($err, $msg);
+
+foreach my $system ($clearadm->FindSystem ($host)) {
+ ($err, $msg) = $clearadm->TrimLoadavg ($$system{name});
+
+ if ($msg eq 'Records deleted' or $msg eq '') {
+ verbose "Scrub loadavg $$system{name}: $err $msg:";
+ } else {
+ error "#$err: $msg";
+ } # if
+
+ foreach my $filesystem ($clearadm->FindFilesystem ($$system{name}, $fs)) {
+ ($err, $msg) = $clearadm->TrimFS ($$system{name}, $$filesystem{filesystem});
+
+ if ($msg eq 'Records deleted' or $msg eq '') {
+ verbose "Scrub filesystem $$system{name}:$$filesystem{filesystem}: $err $msg";
+ } else {
+ error "#$err: $msg";
+ } # if
+ } # foreach
+} # foreach
+
+# TODO: These should be configurable
+my $sixMonthsAgo = SubtractDays (Today2SQLDatetime, 180);
+
+my %runlog = (
+ task => 'Scrub',
+ started => Today2SQLDatetime,
+);
+
+# Scrub old alertlogs
+($runlog{status}, $runlog{message}) =
+ $clearadm->DeleteAlertlog ("timestamp<='$sixMonthsAgo'");
+
+verbose "$runlog{task} alertlog: $runlog{status} $runlog{message}";
+
+$clearadm->AddRunlog (%runlog);
+
+$runlog{started} = Today2SQLDatetime;
+
+# Scrub old runlogs
+($runlog{status}, $runlog{message}) =
+ $clearadm->DeleteRunlog ("started<='$sixMonthsAgo'");
+
+verbose "$runlog{task} runlog: $runlog{status} $runlog{message}";
+
+$clearadm->AddRunlog (%runlog);
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<FindBin>
+
+L<Getopt::Long|Getopt::Long>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ Clearadm
+ DateUtils
+ Display
+ TimeUtils
+ Utils
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/Clearadm.pm">Clearadm</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/DateUtils.pm">DateUtils</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/TimeUtils.pm">TimeUtils</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Utils.pm">Utils</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this script
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2010, ClearSCM, Inc. All rights reserved.
+
+=cut
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: clearagent.pl,v $
+
+Daemon process to run commands on current host in response to requests from
+other hosts.
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.11 $
+
+=item Created:
+
+Mon Dec 13 09:13:27 EST 2010
+
+=item Modified:
+
+$Date: 2011/02/02 18:43:53 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage clearagent.pl: [-u|sage] [-ve|rbose] [-deb|ug]
+
+ Where:
+ -u|sage: Displays usage
+
+ -ve|rbose: Be verbose
+ -de|bug: Output debug messages
+
+ -da|emon: Run in daemon mode (Default)
+ -m|ultithreaded: Multithread requests (Default)
+ -p|idfile: File to be created with the pid written to it (Default:
+ clearagent.pid). Note: pidfile is only written if -daemon
+ is specified.
+
+=head1 DESCRIPTION
+
+This script normally runs as a daemon and accepts requests from other hosts to
+execute commands locally and send back the results.
+
+=cut
+
+use strict;
+use warnings;
+
+use Getopt::Long;
+use FindBin;
+
+use lib "$FindBin::Bin/lib", "$FindBin::Bin/../lib";
+
+use Clearadm;
+use Clearexec;
+use Display;
+use Utils;
+
+my $VERSION = '$Revision: 1.11 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+my $pidfile = "$Clearexec::CLEAROPTS{CLEAREXEC_RUNDIR}/$FindBin::Script.pid";
+
+# Augment PATH with $Clearadm::CLEAROPTS{CLEARADM_BASE}
+$ENV{PATH} .= ":$Clearadm::CLEAROPTS{CLEARADM_BASE}";
+
+my $clearexec;
+
+# Main
+my $multithreaded = $Clearexec::CLEAROPTS{CLEAREXEC_MULTITHREADED};
+my $daemon = 1;
+
+GetOptions (
+ 'usage' => sub { Usage },
+ 'verbose' => sub { set_verbose },
+ 'debug' => sub { set_debug },
+ 'daemon!' => \$daemon,
+ 'multithreaded!' => \$multithreaded,
+ 'pidfile=s' => \$pidfile,
+) or Usage "Invalid parameter";
+
+Usage 'Extraneous options: ' . join ' ', @ARGV
+ if @ARGV;
+
+$clearexec = Clearexec->new;
+
+$clearexec->setMultithreaded ($multithreaded);
+
+my $logfile = "$Clearexec::CLEAROPTS{CLEAREXEC_LOGDIR}/$FindBin::Script.log";
+
+EnterDaemonMode $logfile, $logfile, $pidfile
+ if $daemon;
+
+display "$FindBin::Script V$VERSION started at " . localtime;
+
+$clearexec->startServer;
+
+verbose "Server running";
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<FindBin>
+
+L<Getopt::Long|Getopt::Long>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ Clearexec
+ Display
+ Utils
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/Clearexec.pm">Clearexec</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Utils.pm">Utils</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this script
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2010, ClearSCM, Inc. All rights reserved.
+
+=cut
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: clearexec.pl,v $
+
+Execute commands on the remote system
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.11 $
+
+=item Created:
+
+Mon Dec 13 09:13:27 EST 2010
+
+=item Modified:
+
+$Date: 2012/04/27 14:47:22 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage clearexec.pl: [-u|sage] [-ve|rbose] [-deb|ug]
+ [-h|ost <host>] [-p|ort <port>] [<cmd>]
+
+ Where:
+ -u|sage: Displays usage
+
+ -ve|rbose: Be verbose
+ -deb|ug: Output debug messages
+
+ -h|ost <host>: Host to contact (Default: localhost)
+ -p|ort <port>: Port to connect to (Default: 25327)
+ <cmd> Command to perform
+
+=head1 DESCRIPTION
+
+This script exercises the clearserver.pl daemon by executing a command on the
+remote host:port that the clearserver.pl daemon is running on
+
+=cut
+
+use strict;
+use warnings;
+
+use Getopt::Long;
+use FindBin;
+use Term::ANSIColor qw (color);
+
+use lib "$FindBin::Bin/lib", "$FindBin::Bin/../lib";
+
+use Clearexec;
+use CmdLine;
+use Display;
+use Utils;
+
+my $VERSION = '$Revision: 1.11 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+my $me = $FindBin::Script;
+ $me =~ s/\.pl$//;
+
+local $0 = $me;
+
+my $host = $Clearexec::CLEAROPTS{CLEAREXEC_HOST};
+my $port = $Clearexec::CLEAROPTS{CLEAREXEC_PORT};
+
+my $clearexec;
+
+sub CmdLoop () {
+ my ($line, $result);
+
+ my $prompt = color ('BOLD YELLOW') . "$me->$host:" . color ('RESET');
+
+ $CmdLine::cmdline->set_prompt ($prompt);
+
+ while (($line, $result) = $CmdLine::cmdline->get ()) {
+ last unless defined $line;
+ last if $line =~ /exit|quit/i;
+
+ my ($status, @output) = $clearexec->execute ($line);
+
+ last if $line =~ /stopserver/i;
+
+ if ($status) {
+ error "Non zero status returned from $line ($status)\n" . join "\n", @output;
+ } else {
+ display join "\n", @output;
+ display "Status: $status"
+ if $status;
+ } # if
+ } # while
+
+ return;
+} # CmdLoop
+
+# Main
+GetOptions (
+ 'usage' => sub { Usage },
+ 'verbose' => sub { set_verbose },
+ 'debug' => sub { set_debug },
+ 'host=s' => \$host,
+ 'port=s' => \$port,
+) or Usage "Invalid parameter";
+
+my $cmd = join ' ', @ARGV;
+
+verbose "$FindBin::Script V$VERSION";
+
+$clearexec =Clearexec->new;
+
+my ($status, @output);
+
+$status = $clearexec->connectToServer ($host, $port);
+
+error "Unable to connect to $host:$port", 1
+ unless $status;
+
+if ($cmd ne '') {
+ ($status, @output) = $clearexec->execute ($cmd);
+
+ if ($status) {
+ error "Unable to execute $cmd (Status: $status)\n" . join ("\n", @output), 1;
+ } else {
+ display join "\n", @output;
+ display "Status: $status";
+ } # if
+} else {
+ CmdLoop;
+} # if
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<FindBin>
+
+L<Getopt::Long|Getopt::Long>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ Clearexec
+ Display
+ Utils
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/Clearexec.pm">Clearexec</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Utils.pm">Utils</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this script
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2010, ClearSCM, Inc. All rights reserved.
+
+=cut
--- /dev/null
+/*==============================================================================
+
+GRC multi-level script-free pure-CSS menuing system stylesheet. This code is
+hereby placed into the public domain by its author Steve Gibson. It maybe freely
+used for any purpose whatsoever.
+
+Computed Geometries: with a default 12px font, 1.0em == 12px and
+1px == 0.08333em.
+Thus, our 98px wide Freeware & Research buttons are 8.166666em wide.
+
+PUBLIC DOMAIN CONTRIBUTION NOTICE
+
+This work has been explicitly placed into the Public Domain for the benefit of
+anyone who may find it useful for any purpose whatsoever.
+==============================================================================*/
+
+/*================= STYLES FOR THE GRC MASTHEAD & CONTROLS ===================*/
+/* for all browsers (non-IE) that obey min-width */
+.menuminwidth0 {
+ position:relative;
+ border:0;
+ margin:0;
+ padding:0;
+ width:100%;
+ height:55px; /* 36px masthead height + 18px button height + 1px lower border*/
+ min-width:560px;
+}
+
+/* suppress our whole menu when not an interactive mode (when printing, etc.) */
+@media print, projection { .menuminwidth0 { display:none; } }
+
+* html .menuminwidth1 { /* this allows IE5/6 to simulate min-width capability */
+ position:relative; /* we can simulate a minimum width by creating a large */
+ float:left; /* border in this first div, then placing our content */
+ height: 1px; /* into a second nested div (see 2nd nested div next */
+ border-left:560px solid #fff; /* CSS box-model borders are a fixed size */
+}
+
+/* used to simulate min-width capability for IE5/6 */
+* html .menuminwidth2 {
+ position:relative;
+ margin-left:-560px;
+ height: 1px;
+}
+
+#masthead {
+ position:relative; /* position our child objects relative to this div */
+ float:left;
+ vertical-align:top; /* protect from super-large user text sizing */
+ border:0;
+ margin:0;
+ padding:0;
+ width:100%; /* grey-fill the entire width */
+ height:36px; /* set the overall height above the menu-bar */
+ background:#f3fefe; /* a very light shade of grey */
+}
+
+#mastheadlogo {
+ /*float:left;*/
+ vertical-align:top;
+ border:0;
+ padding:0;
+ margin:6px 0 0 7px;
+ height:56px;
+}
+
+/* GRC's focus label */
+#focus {
+ position:absolute;
+ border:0;
+ margin:0;
+ padding:0;
+ top:15px;
+ left:301px;
+ width:121px;
+ height:13px;
+}
+
+/* search button */
+#search {
+ position:absolute;
+ border:0;
+ margin:0;
+ padding:0;
+ top:7px;
+ right:6px;
+ width:60px;
+ height:19px;
+}
+
+/* search text field */
+#text {
+ position:absolute;
+ border:1px solid #404040;
+ margin:0;
+ padding:0 0 0 2px; /* move the left starting point a bit right */
+ top:7px;
+ right:165px;
+ width:12em; /* search field width */
+/* height:1.215em; we'll define this at the bottom of our style sheet */
+ font-size:14px !important;
+ background:#fefefe;
+}
+
+/*========================= TOP OF THE MENU CASCADE ==========================*/
+.menu {
+ position:relative; /* establish a menu-relative positioning context */
+ float:left; /* play nicely with others */
+ margin:0;
+ padding:0;
+ border:0;
+ height:18px; /* the menu's overall height */
+ width:100%; /* we always want our menu to fill the available space */
+ background:#ffdb17;
+ font-family: Verdana, Arial, Helvetica, sans-serif;
+ font-size:12px; /* this (and also below) sets the menu's font size */
+ font-weight:bold;
+ border-bottom:1px solid black; /* give us a black border underneath */
+}
+
+.menu img {
+ vertical-align: top; /* prevent images from being pushed down by text */
+}
+
+.menu ul {
+ margin:0;
+ list-style-type:none; /* we don't want to view the list as a list */
+ line-height:1.5em; /* globally set the menu's item spacing. note */
+} /* this must be 1.0 or 1.5 or 2.0 for Mozilla */
+
+.menu li {
+ float:left; /* this creates the side-by-side array of top-level buttons */
+ position:relative; /* create local positioning contexts for each button */
+ margin:0;
+ width:85px;
+}
+
+.menu ul li table {
+ margin:-1px 0; /* IE5 needs -1px top and bottom table margins */
+ margin:0; /* re-zero the table margins for everyone but IE5 */
+ border-collapse:collapse; /* IE5 needs this for the sub-menus to work */
+ font-size:12px; /* this sets the base font size for our entire menu */
+}
+
+.drop {
+ display:block;
+ padding:0px 0.33em; /* this sets the l/r margins for our menu item */
+ margin:0;
+ text-align:right; /* this right alignment goes with the float:left below */
+ cursor:pointer; /* IE tries to switch back to an I-beam, don't let it */
+ cursor:hand; /* IE5 only knows about "hand", so set it both ways */
+}
+
+.drop span { /* this simultaneously left and right aligns the text and */
+ float:left; /* the >> in the drop-down menus which link to sub-menus */
+}
+
+.rightmenu {
+ position:relative; /* establish a local positioning context for YAH label */
+ float:right; /* and right-align it at the top of our page */
+}
+
+/*======================== TOP LEVEL MENU DEFINITIONS ========================*/
+.menu a {
+ text-decoration: none;
+}
+
+.menu a:link {
+ color:black;
+}
+
+.menu a:visited {
+ color: black;
+}
+
+.menu a:hover {
+ color:blue;
+}
+
+.menu ul li ul {
+ display:none; /* initially hide the entire list hierarchy */
+ padding:1px; /* this is our box border width */
+}
+
+.menu ul li a,
+.menu ul li a:visited { /* unselected top-level menu items */
+ display:block;
+ float:left;
+ text-decoration:none;
+ height:18px;
+}
+
+.menu ul li:hover a,
+.menu ul li a:hover { /* selected top-level menu items */
+ display:block;
+ border-top:1px solid #000; /* these 2 lines create the push-in illusion */
+ height:16px;
+}
+
+/*======================== 2ND LEVEL MENU DEFINITIONS ========================*/
+
+/* 2nd level drop-down box */
+.menu ul li:hover ul,
+.menu ul li a:hover ul {
+ display:block;
+ position:absolute;
+ margin:0;
+ top:18px; /* place us just up underneath the top-level images */
+ left:-1px; /* left-align our drop-down to the previous button border */
+ height:auto; /* the drop-down height will be determiend by line count */
+ width:13.5em;
+ color:black; /* this sets the unselected-text color */
+ background:black; /* this sets our menu's effective "border" color */
+}
+
+.menu ul li:hover ul.leftbutton,
+.menu ul li a:hover ul.leftbutton {/* our first dropdown should not be skewed */
+ left:0px;
+}
+
+.menu ul li:hover ul.skinny,
+.menu ul li a:hover ul.skinny { /* 2nd level skinny drop-down box */
+ width:8.08333em; /* with a 12px default font, this is 97px width (97/12) */
+}
+
+.menu ul.rightmenu li:hover ul,
+.menu ul.rightmenu li a:hover ul { /* 2nd level neighborhood drop-down box */
+ left:auto;
+ right:0; /* nudge the right menu right to line up under the border */
+ width:400px; /* with a 12px default font, this is 228px width (228/12) */
+}
+
+/* IE5/6 needs a tweak here */
+* html .menu ul.rightmenu li a:hover ul {
+ right:-1px;
+}
+
+/* 2nd level unselected items */
+.menu ul li:hover ul li a,
+.menu ul li a:hover ul li a {
+ border:0;
+ margin:0;
+ padding:0;
+ height:auto;
+ color:#000; /* this sets the unselected drop-down text color */
+ background:#fef5d8; /* this sets the drop-down menu background color */
+ width:13.5em;
+}
+
+/* 2nd level selected item */
+.menu ul li:hover ul li:hover a,
+.menu ul li a:hover ul li a:hover {
+ color:black;
+ background:white;
+}
+
+/* 2nd level un+selected items */
+.menu ul li:hover ul.skinny li a,
+.menu ul li a:hover ul.skinny li a,
+.menu ul li:hover ul.skinny li a:hover,
+.menu ul li a:hover ul.skinny li a:hover {
+ width:8.08333em;
+}
+
+/*======================== 3RD LEVEL MENU DEFINITIONS ========================*/
+
+/* hide inactive 3rd-level menus */
+.menu ul li:hover ul li ul,
+.menu ul li a:hover ul li a ul {
+ visibility:hidden;
+}
+
+/* 3rd level drop-down box */
+.menu ul li:hover ul li:hover ul,
+.menu ul li a:hover ul li a:hover ul {
+ visibility:visible;
+ position:absolute;
+ margin-top:-1px; /* bring the top edge of the 3rd level menu up one */
+ top:0;
+ left:8.08333em;
+ width:14em;
+}
+
+/* 3rd level unselected items */
+.menu ul li:hover ul li:hover ul li a,
+.menu ul li a:hover ul li a:hover ul li a {
+ width:14em;
+ background:#fef5d8;
+}
+
+/* level3 selected items */
+.menu ul li:hover ul li:hover ul li a:hover,
+.menu ul li a:hover ul li a:hover ul li a:hover {
+ width:14em;
+ background:white;
+}
+
+/*
+the Mac's standard Safari browser will not see this code but every other browser
+will and should Safari barfs on the illegal pound sign (#) after the rule's
+property val
+*/
+#text {
+ height:1.215em;#
+}
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: cleartasks.pl,v $
+
+Scrub Clearadm records
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.25 $
+
+=item Created:
+
+Sun Jan 2 19:40:28 EST 2011
+
+=item Modified:
+
+$Date: 2013/06/02 18:47:26 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage cleartasks.pl: [-u|sage] [-ve|rbose] [-deb|ug]
+
+ Where:
+ -u|sage: Displays usage
+
+ -v|erbose: Be verbose
+ -de|bug: Output debug messages
+
+ -da|emon: Run in daemon mode (Default: yes)
+ -p|idfile: File to be created with the pid written to it (Default:
+ cleartasks.pid). Note: pidfile is only written if -daemon is
+ specified.
+
+=head1 DESCRIPTION
+
+Examine the Clearadm schedule and perform the tasks required.
+
+=cut
+
+use strict;
+use warnings;
+
+use FindBin;
+use Getopt::Long;
+
+use lib "$FindBin::Bin/lib", "$FindBin::Bin/../lib";
+
+use Clearadm;
+use Clearexec;
+use DateUtils;
+use Display;
+use TimeUtils;
+use Utils;
+
+my $VERSION = '$Revision: 1.25 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+my $logfile = "$Clearadm::CLEAROPTS{CLEARADM_LOGDIR}/$FindBin::Script.log";
+my $pidfile = "$Clearadm::CLEAROPTS{CLEARADM_RUNDIR}/$FindBin::Script.pid";
+my $daemon = 1;
+
+# Augment PATH with $Clearadm::CLEAROPTS{CLEARADM_BASE}
+$ENV{PATH} .= ":$Clearadm::CLEAROPTS{CLEARADM_BASE}";
+
+my ($clearadm, $clearexec);
+
+sub HandleSystemNotCheckingIn (%) {
+ my (%system) = @_;
+
+ my $startTime = time;
+
+ my $message = "Unable to connect to system $system{name}:$system{port}";
+
+ my %runlog = (
+ task => 'System checkin',
+ started => Today2SQLDatetime,
+ status => 1,
+ message => $message,
+ system => $system{name},
+ );
+
+ my ($err, $msg, $lastid) = $clearadm->AddRunlog (%runlog);
+
+ $clearadm->Error ("Unable to add to runlog (Status: $err)\n$msg") if $err;
+
+ # Check to see if we should notify anybody about this non-responding system
+ my %notification = $clearadm->GetNotification ('System checkin');
+
+ my $when = Today2SQLDatetime;
+ my $nomorethan = lc $notification{nomorethan};
+ my $systemLink = $Clearadm::CLEAROPTS{CLEARADM_WEBBASE};
+ $systemLink .= "/systemdetails.cgi?system=$system{name}";
+ my $runlogLink = $Clearadm::CLEAROPTS{CLEARADM_WEBBASE};
+ $runlogLink .= "/runlog.cgi?id=$lastid";
+ my $subject = "System is not responding (Is clearagent running?)";
+ $message = <<"END";
+<center>
+<h1><font color="red">Alert</font> System not responding!</h1>
+</center>
+
+<p>On $when the system <a href="$systemLink">$system{name}</a> was <a
+href="$runlogLink">not responding</a> to clearagent requests. This can happen if
+clearagent is not setup and running on the system.</p>
+END
+
+ $clearadm->Notify (
+ $notification{name},
+ $subject,
+ $message,
+ 'System Checkin',
+ $system{name},
+ undef,
+ $lastid,
+ );
+
+ verbose "$system{name}: $subject";
+
+ return;
+} # HandleSystemNotCheckingIn
+
+sub SystemsCheckin () {
+ foreach ($clearadm->FindSystem) {
+ my %system = %$_;
+
+ next if $system{active} eq 'false';
+
+ verbose "Contacting system $system{name}:$system{port}";
+
+ my $startTime = time;
+
+ my $status = $clearexec->connectToServer (
+ $system{name},
+ $system{port}
+ );
+
+ unless ($status) {
+ HandleSystemNotCheckingIn %system;
+ next;
+ } # unless
+
+ $clearexec->disconnectFromServer;
+
+ verbose 'Successfully checked in with system: '
+ . "$system{name}:$system{port}";
+
+ display __FILE__ . " DEBUG: System undefined 1" unless $system{name};
+ $clearadm->UpdateSystem (
+ $system{name},
+ (lastheardfrom => Today2SQLDatetime)
+ );
+
+ $clearadm->ClearNotifications ($system{name})
+ if $system{notification} and $system{notification} eq 'Heartbeat';
+ } # foreach
+
+ return;
+} # SystemsCheckin
+
+sub UpdateRunlog ($$$$) {
+ my ($status, $startTime, $task, $output) = @_;
+
+ my %runlog = (
+ task => $$task{name},
+ system => $$task{system},
+ started => Today2SQLDatetime,
+ );
+
+ $runlog{status} = $status;
+
+ if ($status == 0) {
+ if (@$output) {
+ $runlog{message} = join "\n", @$output;
+ } else {
+ $runlog{message} = 'Successful execution of ';
+ $runlog{message} .= "$$task{name}: $$task{command}";
+ } # if
+ } else {
+ if (@$output) {
+ $runlog{message} = join "\n", @$output;
+ } else {
+ $runlog{message} = 'Unable to execute ';
+ $runlog{message} .= "$$task{name}: $$task{command} ";
+ $runlog{message} .= join (' ', @$output);
+ } # if
+ } # if
+
+ my ($err, $msg, $lastid) = $clearadm->AddRunlog (%runlog);
+
+ $clearadm->Error ($msg, $err) if $err;
+
+ return $lastid;
+} # UpdateRunlog
+
+sub MakeSystemLink ($) {
+ my ($system) = @_;
+
+ return "$Clearadm::CLEAROPTS{CLEARADM_WEBBASE}/systemdetails.cgi?system="
+ . $system;
+} # MakeSystemLink
+
+sub MakeLoadavgLink ($) {
+ my ($system) = @_;
+
+ return "$Clearadm::CLEAROPTS{CLEARADM_WEBBASE}/plot.cgi?type=loadavg&system="
+ . "$system&scaling=Hour&points=24";
+} # MakeLoadavgLink
+
+sub ProcessLoadavgErrors ($$$$@) {
+ # TODO: Also need to handle the case where the error was something other
+ # than "Load average over threshold". Perhaps by having different return
+ # status. Also, runlog entry #22169 never reported!
+ my ($notification, $task, $system, $lastid, @output) = @_;
+
+ my $when = Today2SQLDatetime;
+
+ foreach (@output) {
+ # We need to log this output. Write it to STDOUT
+ display $_;
+
+ my ($subject, $message, $currLoadavg, $threshold, $systemLink, $loadavgLink);
+
+ if (/System: (\w+) Loadavg (\d+\.\d+) Threshold (\d+\.\d+)/) {
+ $system = $1;
+ $currLoadavg = $2;
+ $threshold = $3;
+ $systemLink = MakeSystemLink $system;
+ $loadavgLink = MakeLoadavgLink $system;
+ $subject = "Load average of $currLoadavg exceeds threshold ";
+ $subject .= "($threshold)";
+ $message = <<"END";
+<center>
+<h1><font color="red">Alert</font> Load Average is over the threshold!</h1>
+</center>
+
+<p>On $when the system <a href="$systemLink">$system</a>'s load avg
+(<a href="$loadavgLink">$currLoadavg</a>) had exceeded the threshold set for
+this system ($threshold).</p>
+END
+ } elsif (/ERROR.*system\s+(\S+):/) {
+ $system = $1;
+ $systemLink = MakeSystemLink $system;
+ $subject = "Error trying to obtain Loadavg";
+ $message = <<"END";
+<center>
+<h1><font color="red">Alert</font> Unable to obtain Loadavg!</h1>
+</center>
+
+<p>On $when we were unable to obtain the Loadavg for
+system <a href="$systemLink">$system</a>.</p>
+
+<p>The following was the error message:</p>
+<pre>$_</pre>
+END
+ } else {
+ $message = <<"END";
+<p>On $when on the system $system, we were unable to parse the Loadavg output. This is what we saw:</p>
+
+<pre>
+END
+ $message .= join "\n", @output;
+ $message .= "</pre>";
+ $clearadm->Error ($message, -1);
+
+ last;
+ } # if
+
+ $clearadm->Notify (
+ $notification,
+ $subject,
+ $message,
+ $task,
+ $system,
+ undef,
+ $lastid,
+ );
+ } # foreach
+
+ return;
+} # ProcessLoadAvgErrors
+
+sub ProcessFilesystemErrors ($$$$@) {
+ # TODO: Also need to handle the case where the error was something other
+ # than "Filesystem over threshold". Perhaps by having different return
+ # status.
+ my ($notification, $task, $system, $lastid, @output) = @_;
+
+ my $when = Today2SQLDatetime;
+
+ my %system;
+
+ foreach (@output) {
+ # We need to log this output. Write it to STDOUT
+ display $_;
+
+ if (/System:\s*(\S+)\s*Filesystem:\s*(\S+)\s*Used:\s*(\d+\.\d+)%\s*Threshold:\s*(\d+)/) {
+ my %fsinfo = (
+ filesystem => $2,
+ usedPct => $3,
+ threshold => $4
+ );
+
+ if ($system{$1}) {
+ $system{$1} = [$system{$1}, \%fsinfo];
+ } else {
+ $system{$1} = \%fsinfo;
+ } # if
+ } # if
+ } # foreach
+
+ foreach my $systemName (keys %system) {
+ my @fsinfo;
+
+ if (ref $system{$systemName} eq 'HASH') {
+ push @fsinfo, $system{$systemName};
+ } else {
+ push @fsinfo, @{$system{$systemName}};
+ } # if
+
+ my $systemLink = MakeSystemLink ($systemName);
+ my $subject = 'Filesystem has exceeded threshold';
+ my $message = <<"END";
+<center>
+<h1><font color="red">Alert</font> Filesystem is over the threshold!</h1>
+</center>
+
+<p>On $when the following filesystems on <a href="$systemLink">$systemName</a>
+were over their threshold.</p>
+
+<ul>
+END
+ foreach (@fsinfo) {
+ my %fsinfo = %{$_};
+ my $filesystemLink = $Clearadm::CLEAROPTS{CLEARADM_WEBBASE};
+ $filesystemLink .= "/plot.cgi?type=filesystem&system=$systemName";
+ $filesystemLink .= "&filesystem=$fsinfo{filesystem}";
+ $filesystemLink .= '&scaling=Day&points=7';
+ $message .= "<li>Filesystem <a href=\"$filesystemLink\">";
+ $message .= "$fsinfo{filesystem}</a> is $fsinfo{usedPct}% full. Threshold is ";
+ $message .= "$fsinfo{threshold}%</li>";
+ } # foreach
+
+ $message .= "</ul>";
+
+ $clearadm->Notify (
+ $notification,
+ $subject,
+ $message,
+ $task,
+ $systemName,
+ undef,
+ $lastid,
+ );
+ } # foreach
+
+ return;
+} # ProcessFilesystemErrors
+
+sub NonZeroReturn ($$$$$$) {
+ my ($system, $notification, $status, $lastid, $output, $task) = @_;
+
+ my @output = @{$output};
+ my %task = %{$task};
+
+ my $when = Today2SQLDatetime;
+
+ my $subject = "Non zero return from $task{command} "
+ . "executing on $system";
+ my $taskLink = $Clearadm::CLEAROPTS{CLEARADM_WEBBASE};
+ $taskLink .= "/tasks.cgi?task=$task{name}";
+ my $similarLink = $Clearadm::CLEAROPTS{CLEARADM_WEBBASE};
+ $similarLink .= "/runlog.cgi?system=$task{system}"
+ . "&status=$status&"
+ . "&task=$task{name}";
+ my $runlogLink = $Clearadm::CLEAROPTS{CLEARADM_WEBBASE};
+ $runlogLink .= "/runlog.cgi?id=$lastid";
+ my $message = <<"END";
+<center>
+<h1><font color="red">Alert</font> Non zero status from script execution!</h1>
+</center>
+
+<p>On $when, while executing <a href="$taskLink">$task{name}</a> on
+$task{system}, a non zero status of $status was returned. Here is the resulting
+output:</p><blockquote><pre>
+END
+
+ $message .= join "\n", @output;
+ $message .= <<"END";
+</pre></blockquote>
+<p>You may wish to examine the individual <a href="$runlogLink">runlog entry</a>
+that caused this alert or a list of <a href="$similarLink">similar
+failures</a>.</p>
+END
+
+ $message .= "</pre></blockquote>";
+
+ $clearadm->Notify (
+ $notification,
+ $subject,
+ $message,
+ $task,
+ $system,
+ undef,
+ $lastid,
+ );
+
+ return;
+} # NonZeroReturn
+
+sub ExecuteTask ($%) {
+ my ($sleep, %task) = @_;
+
+ my ($status, @output, %system, $subject, $message);
+
+ verbose_nolf "Performing task $task{name}";
+
+ my %notification = $clearadm->GetNotification ($task{notification});
+
+ my $startTime = time;
+
+ if ($task{system} =~ /localhost/i) {
+ verbose " on localhost";
+ ($status, @output) = Execute "$task{command} 2>&1";
+ } else {
+ %system = $clearadm->GetSystem ($task{system});
+
+ verbose " on $system{name}";
+
+ $status = $clearexec->connectToServer (
+ $system{name},
+ $system{port}
+ );
+
+ unless ($status) {
+ $output[0] = "Unable to connect to system $system{name}:$system{port} to "
+ . "execute $task{command}";
+ $status = -1;
+ } else {
+ ($status, @output) = $clearexec->execute ($task{command});
+
+ $output[0] = "Unable to exec $task{command} on $system{name}"
+ if $status == -1;
+ } # unless
+
+ $clearexec->disconnectFromServer;
+ } # if
+
+ my $lastid = UpdateRunlog ($status, $startTime, \%task, \@output);
+
+ if ($status != 0) {
+ if ($notification{cond}
+ and $notification{cond} =~ /non zero return/i) {
+ NonZeroReturn (
+ $system{name},
+ $notification{name},
+ $status,
+ $lastid,
+ \@output,
+ \%task
+ );
+ } elsif ($notification{cond} =~ /loadavg over threshold/i) {
+ ProcessLoadavgErrors ($notification{name}, $task{name}, $system{name}, $lastid, @output);
+ } elsif ($notification{cond} =~ /filesystem over threshold/i) {
+ ProcessFilesystemErrors ($notification{name}, $task{name}, $system{name}, $lastid, @output);
+ } # if
+ } else {
+ $clearadm->ClearNotifications ($task{system});
+ } # if
+
+ my ($err, $msg) = $clearadm->UpdateSchedule (
+ $task{schedulename},
+ ( 'lastrunid' => $lastid ),
+ );
+
+ $clearadm->Error ($msg, $err) if $err;
+
+ $sleep -= time - $startTime;
+
+ return $sleep;
+} # ExecuteTask
+
+# Main
+GetOptions (
+ 'usage' => sub { Usage },
+ 'verbose' => sub { set_verbose },
+ 'debug' => sub { set_debug },
+ 'daemon!' => \$daemon,
+ 'pidfile=s' => \$pidfile,
+) or Usage "Invalid parameter";
+
+Usage 'Extraneous options: ' . join ' ', @ARGV
+ if @ARGV;
+
+EnterDaemonMode $logfile, $logfile, $pidfile
+ if $daemon;
+
+display "$FindBin::Script V$VERSION started at " . localtime;
+
+$clearadm = Clearadm->new;
+$clearexec = Clearexec->new;
+
+$clearadm->SetNotify;
+
+while () {
+ # First check in with all systems
+ SystemsCheckin;
+
+ my ($sleep, @workItems) = $clearadm->GetWork;
+
+ foreach (@workItems) {
+ my %scheduledTask = %{$_};
+
+ $scheduledTask{system} ||= 'All systems';
+
+ if ($scheduledTask{system} =~ /all systems/i) {
+ foreach my $system ($clearadm->FindSystem) {
+ $scheduledTask{system} = $$system{name};
+ $sleep = ExecuteTask $sleep, %scheduledTask;
+ } # foreach
+ } else {
+ $sleep = ExecuteTask $sleep, %scheduledTask;
+ } # if
+ } # foreach
+
+ if ($sleep > 0) {
+ verbose "Sleeping for $sleep seconds";
+ sleep $sleep;
+ } # if
+} # foreach
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<FindBin>
+
+L<Getopt::Long|Getopt::Long>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ Clearadm
+ Clearexec
+ DateUtils
+ Display
+ TimeUtils
+ Utils
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/Clearadm.pm">Clearadm</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/Clearexec.pm">Clearexec</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/DateUtils.pm">DateUtils</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/TimeUtils.pm">TimeUtils</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Utils.pm">Utils</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this script
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2010, ClearSCM, Inc. All rights reserved.
+
+=cut
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: deletealertlog.cgi,v $
+
+Delete alertlog entries
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.2 $
+
+=item Created:
+
+Mon Oct 25 11:10:47 PDT 2008
+
+=item Modified:
+
+$Date: 2011/02/02 16:50:27 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage deletealertlog.cgi: [-u|sage] [-ve|rbose] [-d|ebug]
+ alertlogid=[<n>|all]
+
+ Where:
+ -u|sage: Displays usage
+ -ve|rbose: Be verbose
+ -d|ebug: Output debug messages
+
+ alertlogid: Alertlog ID to delete or 'all' to clear the alertlog.
+
+=head2 DESCRIPTION
+
+This script deletes alertlog entries.
+
+=cut
+
+use strict;
+use warnings;
+
+use FindBin;
+use Getopt::Long;
+use CGI qw (:standard :cgi-lib *table start_Tr end_Tr);
+use CGI::Carp 'fatalsToBrowser';
+
+use lib "$FindBin::Bin/lib", "$FindBin::Bin/../lib";
+
+use Clearadm;
+use ClearadmWeb;
+use Display;
+use Utils;
+
+my $VERSION = '$Revision: 1.2 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+my $clearadm;
+
+# Main
+GetOptions (
+ usage => sub { Usage },
+ verbose => sub { set_verbose },
+ debug => sub { set_debug },
+) or Usage 'Invalid parameter';
+
+# Announce ourselves
+verbose "$FindBin::Script v$VERSION";
+
+$clearadm = Clearadm->new;
+
+my %opts = Vars;
+
+my $title = 'Alert Log';
+
+heading $title;
+
+my ($err, $msg) = $clearadm->DeleteAlertlog ($opts{alertlogid});
+
+display h1 {class => 'center'}, $title;
+
+if ($msg eq 'Records deleted') {
+ if ($err > 1) {
+ display h3 {class => 'center'}, "Cleared all alertlog entries";
+ } else {
+ display h3 {class => 'center'}, "Deleted alertlog record";
+ } # if
+
+ displayAlertlog (%opts);
+} else {
+ displayError "Unable to delete alertlog entry (Status: $err)<br>$msg";
+} # if
+
+footing;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<CGI>
+
+L<CGI::Carp|CGI::Carp>
+
+L<FindBin>
+
+L<Getopt::Long|Getopt::Long>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ Clearadm
+ ClearadmWeb
+ Display
+ Utils
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/Clearadm.pm">Clearadm</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/ClearadmWeb.pm">ClearadmWeb</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Utils.pm">Utils</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this script
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2010, ClearSCM, Inc. All rights reserved.
+
+=cut
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: discovery.pl,v $
+
+Update System
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.1 $
+
+=item Created:
+
+Mon Dec 13 09:13:27 EST 2010
+
+=item Modified:
+
+$Date: 2011/01/07 20:48:22 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage updatesystem.pl: [-u|sage] [-ve|rbose] [-deb|ug]
+ [-b|roadcastTime <seconds>]
+
+ Where:
+ -u|sage: Displays usage
+
+ -ve|rbose: Be verbose
+ -deb|ug: Output debug messages
+
+ -broadcastA|ddr <ip>: Broadcast IP (Default: Current subnet)
+ -broadcastT|ime <seconds>: Number of sends to wait for responses to broadcast
+ (Default: 30 seconds)
+
+=head1 DESCRIPTION
+
+This script will discover systems on the local subnet and then add or update
+them in the Clearadm database.
+
+=cut
+
+use strict;
+use warnings;
+
+use Socket;
+
+use FindBin;
+use Getopt::Long;
+
+use lib "$FindBin::Bin/lib", "$FindBin::Bin/../lib";
+
+use Clearadm;
+use Display;
+use Utils;
+
+my $VERSION = '$Revision: 1.1 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+my $clearadm = Clearadm->new;
+
+my $broadcastTime = 10;
+
+sub discover ($) {
+ my ($broadcast) = @_;
+
+ my $startTime = time;
+
+ my %hosts;
+
+ verbose "Performing discovery (for $broadcastTime seconds)...";
+
+ while (<$broadcast>) {
+ if (/from (.*):/) {
+ my $ip = $1;
+ my $hostname = gethostbyaddr (inet_aton ($ip), AF_INET);
+
+ unless ($hosts{$ip}) {
+ verbose "Received response from ($ip): $hostname";
+ $hosts{$ip} = $hostname;
+ } # unless
+ } # if
+
+ last
+ if (time () - $startTime) > $broadcastTime;
+ } # while
+
+ verbose "$broadcastTime seconds has elapsed - discovery complete";
+
+ return %hosts
+} # discover
+
+# Main
+my $broadcastAddress = inet_ntoa (INADDR_BROADCAST);
+
+GetOptions (
+ usage => sub { Usage },
+ verbose => sub { set_verbose },
+ debug => sub { set_debug },
+ 'broadcastTime=s' => \$broadcastTime,
+ 'broadcastAddr=s' => \$broadcastAddress,
+) or Usage "Invalid parameter";
+
+Usage 'Extraneous options: ' . join ' ', @ARGV
+ if @ARGV;
+
+# Announce ourselves
+verbose "$FindBin::Script V$VERSION";
+
+my $broadcastCmd = "ping -b $broadcastAddress 2>&1";
+
+my $pid = open my $broadcast, '-|', $broadcastCmd
+ or error "Unable to do $broadcastCmd", 1;
+
+my %hosts = discover $broadcast;
+
+kill TERM => $pid;
+
+close $broadcast;
+
+my $nbrHosts = scalar keys %hosts;
+
+verbose_nolf "Found $nbrHosts host";
+verbose_nolf 's' if $nbrHosts != 1;
+verbose " on subnet $broadcastAddress";
+
+foreach (sort values %hosts) {
+ my $verbose = get_verbose () ? '-verbose' : '';
+
+ my ($status, @output) = Execute "updatesystem.pl -host $_ $verbose";
+
+ error "Unable to update host $_ (Status: $status)\n"
+ . join ("\n", @output), 1
+ if $status;
+
+ verbose join "\n", @output;
+} # foreach
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<FindBin>
+
+L<Getop::Long|Getopt::Long>
+
+L<Socket>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ Clearadm
+ Display
+ Utils
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/Clearadm.pm">Clearadm</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Utils.pm">Utils</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this script
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2010, ClearSCM, Inc. All rights reserved.
+
+=cut
\ No newline at end of file
--- /dev/null
+###############################################################################
+#
+# File: $RCSfile: clearadm.conf,v $
+# Revision: $Revision: 1.7 $
+# Description: Config file for Clearadm
+# Author: Andrew@ClearSCM.com
+# Created: Wed Dec 15 18:43:12 EST 2010
+# Modified: $Date: 2011/12/26 18:34:58 $
+# Language: conf
+#
+# (c) Copyright 2010, ClearSCM, Inc., all rights reserved
+#
+###############################################################################
+CLEARADM_SERVER: earth
+CLEARADM_PORT: 25327
+CLEARADM_LOADAVG_THRESHOLD: 5.00
+CLEARADM_USERNAME: clearwriter
+CLEARADM_PASSWORD: clearwriter
+CLEARADM_BASE: /opt/clearscm/clearadm
+CLEARADM_LOGDIR: $CLEARADM_BASE/log
+CLEARADM_RUNDIR: $CLEARADM_BASE/var/run
+CLEARADM_WEBBASE: http://$CLEARADM_SERVER/clearadm
+CLEARADM_NOTIFY: Andrew@DeFaria.com
\ No newline at end of file
--- /dev/null
+###############################################################################
+#
+# File: $RCSfile: clearexec.conf,v $
+# Revision: $Revision: 1.2 $
+# Description: Config file for Clearexec
+# Author: Andrew@ClearSCM.com
+# Created: Wed Dec 15 18:43:12 EST 2010
+# Modified: $Date: 2011/01/04 14:44:39 $
+# Language: conf
+#
+# (c) Copyright 2010, ClearSCM, Inc., all rights reserved
+#
+###############################################################################
+CLEAREXEC_HOST: earth
+CLEAREXEC_PORT: 25327
+CLEAREXEC_MULTITHREADED: 1
+CLEAREXEC_LOGDIR: /opt/clearscm/clearadm/log
+CLEAREXEC_RUNDIR: /opt/clearscm/clearadm/var/run
\ No newline at end of file
--- /dev/null
+###############################################################################
+#
+# File: $RCSfile: clearuser.conf,v $
+# Revision: $Revision: 1.1 $
+# Description: Config file for User.pm
+# Author: Andrew@ClearSCM.com
+# Created: Wed Dec 15 18:43:12 EST 2010
+# Modified: $Date: 2010/12/22 12:37:36 $
+# Language: conf
+#
+# (c) Copyright 2010, ClearSCM, Inc., all rights reserved
+#
+###############################################################################
+CLEARUSER_LDAPHOST:
+CLEARUSER_BIND:
+CLEARUSER_BASEDN:
+CLEARUSER_USERNAME:
+CLEARUSER_PASSWORD:
\ No newline at end of file
--- /dev/null
+###############################################################################
+#
+# File: $RCSfile: clearadm,v $
+# Revision: $Revision: 1.3 $
+# Description: Apache config file for Clearadm
+# Author: Andrew@ClearSCM.com
+# Created: Wed Dec 15 18:43:12 EST 2010
+# Modified: $Date: 2011/05/26 05:48:43 $
+# Language: Apache conf
+#
+# (c) Copyright 2010, ClearSCM, Inc., all rights reserved
+#
+###############################################################################
+Alias /clearadm /opt/clearscm/clearadm
+
+<Directory "/opt/clearscm/clearadm">
+ Options Indexes FollowSymLinks ExecCGI
+ AllowOverride None
+ Order allow,deny
+ Allow from all
+ DirectoryIndex index.cgi index.html
+</Directory>
+
+AddHandler cgi-script .cgi
--- /dev/null
+#!/bin/sh
+### BEGIN INIT INFO
+# Provides: clearagent
+# Required-Start: $network
+# Required-Stop: none
+# Default-Start: 2 3 4 5
+# Default-Stop: 0 1 6
+# Short-Description: Starts the clearagent daemon
+# Description: Clearagent is part of the Clearadm package by ClearSCM,
+# Inc. It is a daemon that runs in the background and
+# responds to requests to run commands on the local system
+# and return the results.
+### END INIT INFO
+
+# Author: Andrew DeFaria <Andrew@ClearSCM.com>
+#
+# Do NOT "set -e"
+
+# PATH should only include /usr/* if it runs after the mountnfs.sh script
+PATH=/sbin:/usr/sbin:/bin:/usr/bin
+DESC="Clearagent Daemon"
+NAME=clearagent.pl
+DAEMON=/opt/clearscm/clearadm/$NAME
+PIDFILE=/opt/clearscm/clearadm/var/run/$NAME.pid
+DAEMON_ARGS=""
+SCRIPTNAME=/etc/init.d/$NAME
+RUNASUSER="clearagent"
+
+# Exit if the package is not installed
+[ -x "$DAEMON" ] || exit 0
+
+# Read configuration variable file if it is present
+[ -r /etc/default/$NAME ] && . /etc/default/$NAME
+
+# Load the VERBOSE setting and other rcs variables
+. /lib/init/vars.sh
+
+# Define LSB log_* functions.
+# Depend on lsb-base (>= 3.0-6) to ensure that this file is present.
+. /lib/lsb/init-functions
+
+#
+# Function that starts the daemon/service
+#
+do_start()
+{
+ # Return
+ # 0 if daemon has been started
+ # 1 if daemon was already running
+ # 2 if daemon could not be started
+ start-stop-daemon --start --quiet --pidfile $PIDFILE --exec $DAEMON --test > /dev/null \
+ || return 1
+ start-stop-daemon --start --quiet --pidfile $PIDFILE --exec $DAEMON \
+ --chuid $RUNASUSER \
+ -- $DAEMON_ARGS \
+ || return 2
+}
+
+#
+# Function that stops the daemon/service
+#
+do_stop()
+{
+ # Return
+ # 0 if daemon has been stopped
+ # 1 if daemon was already stopped
+ # 2 if daemon could not be stopped
+ # other if a failure occurred
+ start-stop-daemon --stop --quiet --retry=TERM/30/KILL/5 --pidfile $PIDFILE --name $NAME
+ RETVAL="$?"
+ [ "$RETVAL" = 2 ] && return 2
+ # Wait for children to finish too if this is a daemon that forks
+ # and if the daemon is only ever run from this initscript.
+ # If the above conditions are not satisfied then add some other code
+ # that waits for the process to drop all resources that could be
+ # needed by services started subsequently. A last resort is to
+ # sleep for some time.
+ start-stop-daemon --stop --quiet --oknodo --retry=0/30/KILL/5 --exec $DAEMON
+ [ "$?" = 2 ] && return 2
+ # Many daemons don't delete their pidfiles when they exit.
+ rm -f $PIDFILE
+ return "$RETVAL"
+}
+
+#
+# Function that sends a SIGHUP to the daemon/service
+#
+do_reload() {
+ #
+ # If the daemon can reload its configuration without
+ # restarting (for example, when it is sent a SIGHUP),
+ # then implement that here.
+ #
+ start-stop-daemon --stop --signal 1 --quiet --pidfile $PIDFILE --name $NAME
+ return 0
+}
+
+case "$1" in
+ start)
+ [ "$VERBOSE" != no ] && log_daemon_msg "Starting $DESC" "$NAME"
+ do_start
+ case "$?" in
+ 0|1) [ "$VERBOSE" != no ] && log_end_msg 0 ;;
+ 2) [ "$VERBOSE" != no ] && log_end_msg 1 ;;
+ esac
+ ;;
+ stop)
+ [ "$VERBOSE" != no ] && log_daemon_msg "Stopping $DESC" "$NAME"
+ do_stop
+ case "$?" in
+ 0|1) [ "$VERBOSE" != no ] && log_end_msg 0 ;;
+ 2) [ "$VERBOSE" != no ] && log_end_msg 1 ;;
+ esac
+ ;;
+ status)
+ status_of_proc "$DAEMON" "$NAME" && exit 0 || exit $?
+ ;;
+ #reload|force-reload)
+ #
+ # If do_reload() is not implemented then leave this commented out
+ # and leave 'force-reload' as an alias for 'restart'.
+ #
+ #log_daemon_msg "Reloading $DESC" "$NAME"
+ #do_reload
+ #log_end_msg $?
+ #;;
+ restart|force-reload)
+ #
+ # If the "reload" option is implemented then remove the
+ # 'force-reload' alias
+ #
+ log_daemon_msg "Restarting $DESC" "$NAME"
+ do_stop
+ case "$?" in
+ 0|1)
+ do_start
+ case "$?" in
+ 0) log_end_msg 0 ;;
+ 1) log_end_msg 1 ;; # Old process is still running
+ *) log_end_msg 1 ;; # Failed to start
+ esac
+ ;;
+ *)
+ # Failed to stop
+ log_end_msg 1
+ ;;
+ esac
+ ;;
+ *)
+ #echo "Usage: $SCRIPTNAME {start|stop|restart|reload|force-reload}" >&2
+ echo "Usage: $SCRIPTNAME {start|stop|status|restart|force-reload}" >&2
+ exit 3
+ ;;
+esac
+
+:
--- /dev/null
+#!/bin/sh
+### BEGIN INIT INFO
+# Provides: cleartasks
+# Required-Start: $network $mysql
+# Required-Stop: none
+# Default-Start: 2 3 4 5
+# Default-Stop: 0 1 6
+# Short-Description: Starts the cleartasks daemon
+# Description: Cleartasks are part of the Clearadm package by ClearSCM,
+# Inc. It is a daemon that runs in the background and
+# performs the various predefined and user defined tasks
+# from the Clearadm database
+### END INIT INFO
+
+# Author: Andrew DeFaria <Andrew@ClearSCM.com>
+#
+# Do NOT "set -e"
+
+# PATH should only include /usr/* if it runs after the mountnfs.sh script
+PATH=/sbin:/usr/sbin:/bin:/usr/bin
+DESC="Cleartasks Daemon"
+NAME=cleartasks.pl
+DAEMON=/opt/clearscm/clearadm/$NAME
+PIDFILE=/opt/clearscm/clearadm/var/run/$NAME.pid
+DAEMON_ARGS=""
+SCRIPTNAME=/etc/init.d/$NAME
+RUNASUSER="clearagent"
+
+# Exit if the package is not installed
+[ -x "$DAEMON" ] || exit 0
+
+# Read configuration variable file if it is present
+[ -r /etc/default/$NAME ] && . /etc/default/$NAME
+
+# Load the VERBOSE setting and other rcs variables
+. /lib/init/vars.sh
+
+# Define LSB log_* functions.
+# Depend on lsb-base (>= 3.0-6) to ensure that this file is present.
+. /lib/lsb/init-functions
+
+#
+# Function that starts the daemon/service
+#
+do_start()
+{
+ # Return
+ # 0 if daemon has been started
+ # 1 if daemon was already running
+ # 2 if daemon could not be started
+ start-stop-daemon --start --quiet --pidfile $PIDFILE --exec $DAEMON --test > /dev/null \
+ || return 1
+ start-stop-daemon --start --quiet --pidfile $PIDFILE --exec $DAEMON \
+ --chuid $RUNASUSER \
+ -- $DAEMON_ARGS \
+ || return 2
+}
+
+#
+# Function that stops the daemon/service
+#
+do_stop()
+{
+ # Return
+ # 0 if daemon has been stopped
+ # 1 if daemon was already stopped
+ # 2 if daemon could not be stopped
+ # other if a failure occurred
+ start-stop-daemon --stop --quiet --retry=TERM/30/KILL/5 --pidfile $PIDFILE --name $NAME
+ RETVAL="$?"
+ [ "$RETVAL" = 2 ] && return 2
+ # Wait for children to finish too if this is a daemon that forks
+ # and if the daemon is only ever run from this initscript.
+ # If the above conditions are not satisfied then add some other code
+ # that waits for the process to drop all resources that could be
+ # needed by services started subsequently. A last resort is to
+ # sleep for some time.
+ start-stop-daemon --stop --quiet --oknodo --retry=0/30/KILL/5 --exec $DAEMON
+ [ "$?" = 2 ] && return 2
+ # Many daemons don't delete their pidfiles when they exit.
+ rm -f $PIDFILE
+ return "$RETVAL"
+}
+
+#
+# Function that sends a SIGHUP to the daemon/service
+#
+do_reload() {
+ #
+ # If the daemon can reload its configuration without
+ # restarting (for example, when it is sent a SIGHUP),
+ # then implement that here.
+ #
+ start-stop-daemon --stop --signal 1 --quiet --pidfile $PIDFILE --name $NAME
+ return 0
+}
+
+case "$1" in
+ start)
+ [ "$VERBOSE" != no ] && log_daemon_msg "Starting $DESC" "$NAME"
+ do_start
+ case "$?" in
+ 0|1) [ "$VERBOSE" != no ] && log_end_msg 0 ;;
+ 2) [ "$VERBOSE" != no ] && log_end_msg 1 ;;
+ esac
+ ;;
+ stop)
+ [ "$VERBOSE" != no ] && log_daemon_msg "Stopping $DESC" "$NAME"
+ do_stop
+ case "$?" in
+ 0|1) [ "$VERBOSE" != no ] && log_end_msg 0 ;;
+ 2) [ "$VERBOSE" != no ] && log_end_msg 1 ;;
+ esac
+ ;;
+ status)
+ status_of_proc "$DAEMON" "$NAME" && exit 0 || exit $?
+ ;;
+ #reload|force-reload)
+ #
+ # If do_reload() is not implemented then leave this commented out
+ # and leave 'force-reload' as an alias for 'restart'.
+ #
+ #log_daemon_msg "Reloading $DESC" "$NAME"
+ #do_reload
+ #log_end_msg $?
+ #;;
+ restart|force-reload)
+ #
+ # If the "reload" option is implemented then remove the
+ # 'force-reload' alias
+ #
+ log_daemon_msg "Restarting $DESC" "$NAME"
+ do_stop
+ case "$?" in
+ 0|1)
+ do_start
+ case "$?" in
+ 0) log_end_msg 0 ;;
+ 1) log_end_msg 1 ;; # Old process is still running
+ *) log_end_msg 1 ;; # Failed to start
+ esac
+ ;;
+ *)
+ # Failed to stop
+ log_end_msg 1
+ ;;
+ esac
+ ;;
+ *)
+ #echo "Usage: $SCRIPTNAME {start|stop|restart|reload|force-reload}" >&2
+ echo "Usage: $SCRIPTNAME {start|stop|status|restart|force-reload}" >&2
+ exit 3
+ ;;
+esac
+
+:
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: filesystems.cgi,v $
+
+Filesystems
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.11 $
+
+=item Created:
+
+Mon Oct 25 11:10:47 PDT 2008
+
+=item Modified:
+
+$Date: 2011/02/14 14:50:37 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage filesystems.cgi: [-u|sage] [-ve|rbose] [-d|ebug]
+ [-s|ystem <system>]
+
+ Where:
+ -u|sage: Displays usage
+ -v|erbose: Be verbose
+ -d|ebug: Output debug messages
+
+ -s|sytem: System to report on filesystems (Default: all)
+
+=head2 DESCRIPTION
+
+This script displays all known filesystems
+
+=cut
+
+use strict;
+use warnings;
+
+use FindBin;
+use Getopt::Long;
+use CGI qw (:standard :cgi-lib *table start_Tr end_Tr start_td end_td);
+use CGI::Carp 'fatalsToBrowser';
+
+use lib "$FindBin::Bin/lib", "$FindBin::Bin/../lib";
+
+use Clearadm;
+use ClearadmWeb;
+use Display;
+use Utils;
+
+my $VERSION = '$Revision: 1.11 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+my $subtitle = 'Filesystems Status';
+
+my $system = param 'system';
+
+my $clearadm;
+
+# Main
+GetOptions (
+ usage => sub { Usage },
+ verbose => sub { set_verbose },
+ debug => sub { set_debug },
+ 'system=s' => \$system
+) or Usage 'Invalid parameter';
+
+$system ||= '';
+
+# Announce ourselves
+verbose "$FindBin::Script v$VERSION";
+
+$subtitle .= $system eq ''
+ ? ': All Systems'
+ : ': ' . ucfirst $system;
+
+$clearadm = Clearadm->new;
+
+heading $subtitle;
+
+display h1 {class => 'center'}, $subtitle;
+
+displayFilesystem ($system);
+
+footing;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<CGI>
+
+L<CGI::Carp|CGI::Carp>
+
+L<FindBin>
+
+L<Getopt::Long|Getopt::Long>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ Clearadm
+ ClearadmWeb
+ Display
+ Utils
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/Clearadm.pm">Clearadm</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/ClearadmWeb.pm">ClearadmWeb</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Utils.pm">Utils</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this script
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2010, ClearSCM, Inc. All rights reserved.
+
+=cut
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: getFilesystems.cgi,v $
+
+Get a list of filesystems for a system
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.5 $
+
+=item Created:
+
+Mon Dec 13 09:13:27 EST 2010
+
+=item Modified:
+
+$Date: 2011/01/14 16:29:37 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage getFilesystems.cgi: system=<system>
+
+ Where:
+ system=<system>: Name of the system defined in the Clearadm database to
+ retrieve the filesystems for
+=head1 DESCRIPTION
+
+Retrieve a list of filesystems for a given system and put out a web page that
+specifies the <select> dropdown representing the filesystems for the system.
+This script is intended to be called by AJAX to fill in a dropdown list on a
+web page in response to JavaScript action on another dropdown (a system
+dropdown).
+
+=cut
+
+use strict;
+use warnings;
+
+use FindBin;
+
+use lib "$FindBin::Bin/lib", "$FindBin::Bin/../lib";
+
+use Clearadm;
+use ClearadmWeb;
+use Display;
+
+use CGI qw (:standard :cgi-lib);
+
+my %opts = Vars;
+
+error "System not specified", 1
+ unless $opts{system};
+
+my $clearadm = Clearadm->new;
+
+heading undef, 'short';
+
+display makeFilesystemDropdown ($opts{system}, 'Filesystem');
+
+display end_html;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<FindBin>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ Clearadm
+ ClearadmWeb
+ Display
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/Clearadm.pm">Clearadm</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/ClearadmWeb.pm">ClearadmWeb</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this script
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2010, ClearSCM, Inc. All rights reserved.
+
+=cut
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: getTimestamp.cgi,v $
+
+Get a list of timestamps startTimestamp or endTimestamp elementID
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.6 $
+
+=item Created:
+
+Mon Dec 13 09:13:27 EST 2010
+
+=item Modified:
+
+$Date: 2011/01/20 14:34:24 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage getTimestamp.cgi: system=<system> elementID=<elementID>
+ [filesytem=<filesystem>] [scaling=<scaling>]
+
+ Where:
+ <system>: Name of the system defined in the Clearadm database to
+ retrieve the timestamps for.
+ <elementID>: Element's ID name. Must be one of startTimestamp or
+ endTimeStamp. This is needed by makeTimestampDropdown to
+ determine whether to default the dropdown to Earliest or
+ Latest.
+ [<filesystem>]: If specified then we look at clearadm.filesystem otherwise
+ we look at clearadm.loadavg.
+ <scaling>: Currently one of Minute, Hour, Day or Month. Specifies how
+ Clearadm::GetLoadavg|GetFS will scale the data returned.
+
+=head1 DESCRIPTION
+
+Retrieve a list of timestamps for a given system/filesystem and put out a web
+page that specifies the <select> dropdown representing the timestamps. If
+filesystem is specified then we retrieve information about filesystem snapshots
+in clearadm.fs, otherwise we retrieve information about loadavg snapshots in
+clearadm.loadavg for the given system. Data is scaled by scaling and elementID
+is used to determine if we should make 'Earliest' or 'Latest' the default. This
+script is intended to be called by AJAX to fill in a dropdown list on a web page
+in response to JavaScript action on another dropdown (a system dropdown or an
+interval dropdown).
+
+=cut
+
+use strict;
+use warnings;
+
+use FindBin;
+
+use lib "$FindBin::Bin/lib", "$FindBin::Bin/../lib";
+
+use Clearadm;
+use ClearadmWeb;
+use Display;
+
+use CGI qw (:standard :cgi-lib);
+
+my %opts = Vars;
+
+error "System not specified", 1
+ unless $opts{system};
+
+error "ElementID not specified", 1
+ unless $opts{elementID};
+
+error 'ElementID must be either "startTimestamp" or "endTimestamp"', 1
+ unless $opts{elementID} eq 'startTimestamp' or $opts{elementID} eq 'endTimestamp';
+
+my $default = $opts{elementID} eq 'startTimestamp' ? 'Earliest' : 'Latest';
+
+my $clearadm = Clearadm->new;
+
+heading undef, 'short';
+
+my $name = $opts{elementID} eq 'startTimestamp'
+ ? 'start'
+ : $opts{elementID} eq 'endTimestamp'
+ ? 'end'
+ : 'unknown';
+
+if ($opts{filesystem}) {
+ display makeTimeDropdown
+ 'filesystem',
+ $opts{elementID},
+ $opts{system},
+ $opts{filesystem},
+ $opts{label},
+ $default,
+ $opts{scaling},
+ $name;
+} else {
+ display makeTimeDropdown
+ 'loadavg',
+ $opts{elementID},
+ $opts{system},
+ ucfirst $name,
+ $opts{label},
+ $default,
+ $opts{scaling},
+ $name;
+} # if
+
+display end_html;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<FindBin>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ Clearadm
+ ClearadmWeb
+ Display
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/Clearadm.pm">Clearadm</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/ClearadmWeb.pm">ClearadmWeb</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this script
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2010, ClearSCM, Inc. All rights reserved.
+
+=cut
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: index.cgi,v $
+
+Clearadm: Portal to your Clearcase Infrastructure
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.22 $
+
+=item Created:
+
+Mon Oct 25 11:10:47 PDT 2008
+
+=item Modified:
+
+$Date: 2011/02/14 14:50:48 $
+
+=back
+
+=head1 DESCRIPTION
+
+Clearadm is a web based portal into your Clearcase infrastucture. It seeks to
+provide your CM staff with an easy to use, yet informative interface to locate,
+report on and monitor various aspects of the Clearcase infrastructure.
+
+=cut
+
+use strict;
+use warnings;
+
+use FindBin;
+use Getopt::Long;
+
+use CGI qw (:standard *table start_Tr end_Tr);
+use CGI::Carp 'fatalsToBrowser';
+
+use lib "$FindBin::Bin/lib", "$FindBin::Bin/../lib";
+
+use ClearadmWeb;
+use Clearadm;
+#use Clearcase;
+#use Clearcase::Views;
+use Display;
+use Utils;
+
+my $clearadm = Clearadm->new;
+
+# Main
+GetOptions (
+ 'usage' => sub { Usage },
+ 'verbose' => sub { set_verbose },
+ 'debug' => sub { set_debug },
+) or Usage "Invalid parameter";
+
+# Announce ourselves
+verbose "$ClearadmWeb::APPNAME V$ClearadmWeb::VERSION";
+
+heading;
+
+display p ' ';
+display p <<"END";
+Clearadm is a web based portal into your infrastructure. It seeks to provide
+your system administrative staff with an easy to use, yet informative interface
+to locate, report on and monitor various aspects of your infrastructure.
+END
+ display p <<"END";
+Additionally, Clearacdm is aware of Clearcase servers as well as Clearcase
+objects such as views, vobs, etc. When systems are added to Clearadm that house
+or server Clearcase objects, additional information is collected about those
+objects.
+END
+
+display h1 {class => 'center'}, 'Systems Snapshot';
+
+display start_table {cellspacing => 1};
+
+my $i = 0;
+my $perRow = 5;
+
+display start_Tr;
+
+my @systems = $clearadm->FindSystem;
+
+$perRow = @systems if @systems < $perRow;
+
+foreach (@systems) {
+ my %system = %{$_};
+
+ if ($i++ % $perRow == 0) {
+ display end_Tr;
+ display start_Tr;
+ } # if
+
+ my %load = $clearadm->GetLatestLoadavg ($system{name});
+
+ my $data;
+
+ $data = '<strike>'
+ if $system{active} eq 'false';
+
+ $data .= a {
+ href => "systemdetails.cgi?system=$system{name}"
+ }, ucfirst $system{name};
+
+ if ($system{notification}) {
+ $data .= ' ' . a {
+ href => "alertlog.cgi?system=$system{name}"}, img {
+ src => 'alert.png',
+ border => 0,
+ alt => 'Alert!',
+ title => 'This system has alerts',
+ };
+ } # if
+
+ $data .= '<br>' .
+ a {href =>
+ "plot.cgi?type=loadavg&system=$system{name}&scaling=Hour&points=24"
+ }, img {
+ src => "plotloadavg.cgi?system=$system{name}&tiny=1",
+ border => 0,
+ };
+
+ $data .= '</strike>'
+ if $system{active} eq 'false';
+
+ display td {class => 'dataCentered'}, "$data ",
+ font {class => 'dim' }, "<br>Up: $load{uptime}";
+} # foreach
+
+while ($i % $perRow != 0) {
+ $i++;
+ display td {class => 'data'}, ' ';
+} # while
+
+display end_Tr;
+
+display end_table;
+
+footing;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<CGI|CGI.html>
+
+L<CGI::Carp|CGI::Carp>
+
+L<FindBin>
+
+L<Getopt::Long|Getopt::Long>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ Clearadm
+ ClearadmWeb
+ Display
+ Utils
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/Clearadm.pm">Clearadm</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/ClearadmWeb.pm">ClearadmWeb</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Utils.pm">Utils</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this script
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2010, ClearSCM, Inc. All rights reserved.
+
+=cut
\ No newline at end of file
--- /dev/null
+=pod
+
+=head1 NAME $RCSfile: Clearadm.pm,v $
+
+Object oriented interface to Clearadm.
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.54 $
+
+=item Created
+
+Tue Dec 07 09:13:27 EST 2010
+
+=item Modified
+
+$Date: 2012/11/09 06:43:26 $
+
+=back
+
+=head1 SYNOPSIS
+
+Provides the Clearadm object which handles all interaction with the Clearadm
+database. Similar add/change/delete/update methods for other record types. In
+general you must orient your record hashs to have the appropriately named
+keys that correspond to the database. Also see mothod documentation for
+specifics about the method you are envoking.
+
+ # Create new Clearadm object
+ my $clearadm = new Clearadm;
+
+ # Add a new system
+ my %system = (
+ name => 'jupiter',
+ alias => 'defaria.com',
+ admin => 'Andrew DeFaria',
+ os => 'Linux defaria.com 2.6.32-25-generic-pae #45-Ubuntu SMP Sat Oct 16 21:01:33 UTC 2010 i686 GNU/Linux',
+ type => 'Linux',
+ description => 'Home server',
+ );
+
+ my ($err, $msg) = $clearadm->AddSystem (%system);
+
+ # Find systems matching 'jup'
+ my @systems = $clearadm->FindSystem ('jup');
+
+ # Get a system by name
+ my %system = $clearadm->GetSystem ('jupiter');
+
+ # Update system
+ my %update = (
+ 'region' => 'East Coast',
+ );
+
+ my ($err, $msg) = $clearadm->UpdateSystem ('jupiter', %update);
+
+ # Delete system (Warning: will delete all related records regarding this
+ # system).
+ my ($err, $msg) = $clearadm->DeleteSystem ('jupiter');
+
+=head1 DESCRIPTION
+
+This package provides and object oriented interface to the Clearadm database.
+Methods are provided to manipulate records by adding, updating and deleting
+them. In general you need to specify a hash which contains keys and values
+corresponding to the database field names and values.
+
+=head1 ROUTINES
+
+The following methods are available:
+
+=cut
+
+package Clearadm;
+
+use strict;
+use warnings;
+
+use Carp;
+use DBI;
+use Net::Domain qw(hostdomain);
+
+use FindBin;
+
+use lib "$FindBin::Bin", "$FindBin::Bin/../../lib";
+
+use DateUtils;
+use Display;
+use GetConfig;
+use Mail;
+
+our %CLEAROPTS = GetConfig ("$FindBin::Bin/etc/clearadm.conf");
+
+# Globals
+our $VERSION = '$Revision: 1.54 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+$CLEAROPTS{CLEARADM_USERNAME} = $ENV{CLEARADM_USERNAME}
+ ? $ENV{CLEARADM_USERNAME}
+ : $CLEAROPTS{CLEARADM_USERNAME}
+ ? $CLEAROPTS{CLEARADM_USERNAME}
+ : 'clearwriter';
+$CLEAROPTS{CLEARADM_PASSWORD} = $ENV{CLEARADM_PASSWORD}
+ ? $ENV{CLEARADM_PASSWORD}
+ : $CLEAROPTS{CLEARADM_PASSWORD}
+ ? $CLEAROPTS{CLEARADM_PASSWORD}
+ : 'clearwriter';
+$CLEAROPTS{CLEARADM_SERVER} = $ENV{CLEARADM_SERVER}
+ ? $ENV{CLEARADM_SERVER}
+ : $CLEAROPTS{CLEARADM_SERVER}
+ ? $CLEAROPTS{CLEARADM_SERVER}
+ : 'localhost';
+
+my $defaultFilesystemThreshold = 90;
+my $defaultFilesystemHist = '6 months';
+my $defaultLoadavgHist = '6 months';
+
+# Internal methods
+sub _dberror ($$) {
+ my ($self, $msg, $statement) = @_;
+
+ my $dberr = $self->{db}->err;
+ my $dberrmsg = $self->{db}->errstr;
+
+ $dberr ||= 0;
+ $dberrmsg ||= 'Success';
+
+ my $message = '';
+
+ if ($dberr) {
+ my $function = (caller (1)) [3];
+
+ $message = "$function: $msg\nError #$dberr: $dberrmsg\n"
+ . "SQL Statement: $statement";
+ } # if
+
+ return $dberr, $message;
+} # _dberror
+
+sub _formatValues (@) {
+ my ($self, @values) = @_;
+
+ my @returnValues;
+
+ # Quote data values
+ push @returnValues, $_ eq '' ? 'null' : $self->{db}->quote ($_)
+ foreach (@values);
+
+ return @returnValues;
+} # _formatValues
+
+sub _formatNameValues (%) {
+ my ($self, %rec) = @_;
+
+ my @nameValueStrs;
+
+ push @nameValueStrs, "$_=" . $self->{db}->quote ($rec{$_})
+ foreach (keys %rec);
+
+ return @nameValueStrs;
+} # _formatNameValues
+
+sub _addRecord ($%) {
+ my ($self, $table, %rec) = @_;
+
+ my $statement = "insert into $table (";
+ $statement .= join ',', keys %rec;
+ $statement .= ') values (';
+ $statement .= join ',', $self->_formatValues (values %rec);
+ $statement .= ')';
+
+ my ($err, $msg);
+
+ $self->{db}->do ($statement);
+
+ return $self->_dberror ("Unable to add record to $table", $statement);
+} # _addRecord
+
+sub _deleteRecord ($;$) {
+ my ($self, $table, $condition) = @_;
+
+ my $count;
+
+ my $statement = "select count(*) from $table ";
+ $statement .= "where $condition"
+ if $condition;
+
+ my $sth = $self->{db}->prepare ($statement)
+ or return $self->_dberror ('Unable to prepare statement', $statement);
+
+ $sth->execute
+ or return $self->_dberror ('Unable to execute statement', $statement);
+
+ my @row = $sth->fetchrow_array;
+
+ $sth->finish;
+
+ if ($row[0]) {
+ $count = $row[0];
+ } else {
+ $count = 0;
+ } # if
+
+ return ($count, 'Records deleted')
+ if $count == 0;
+
+ $statement = "delete from $table ";
+ $statement .= "where $condition"
+ if $condition;
+
+ $self->{db}->do ($statement);
+
+ if ($self->{db}->err) {
+ return $self->_dberror ("Unable to delete record from $table", $statement);
+ } else {
+ return $count, 'Records deleted';
+ } # if
+} # _deleteRecord
+
+sub _updateRecord ($$%) {
+ my ($self, $table, $condition, %rec) = @_;
+
+ my $statement = "update $table set ";
+ $statement .= join ',', $self->_formatNameValues (%rec);
+ $statement .= " where $condition"
+ if $condition;
+
+ $self->{db}->do ($statement);
+
+ return $self->_dberror ("Unable to update record in $table", $statement);
+} # _updateRecord
+
+sub _checkRequiredFields ($$) {
+ my ($fields, $rec) = @_;
+
+ foreach my $fieldname (@$fields) {
+ my $found = 0;
+
+ foreach (keys %$rec) {
+ if ($fieldname eq $_) {
+ $found = 1;
+ last;
+ } # if
+ } # foreach
+
+ return "$fieldname is required"
+ unless $found;
+ } # foreach
+
+ return;
+} # _checkRequiredFields
+
+sub _getRecords ($$) {
+ my ($self, $table, $condition) = @_;
+
+ my ($err, $msg);
+
+ my $statement = "select * from $table where $condition";
+
+ my $sth = $self->{db}->prepare ($statement);
+
+ unless ($sth) {
+ ($err, $msg) = $self->_dberror ('Unable to prepare statement', $statement);
+
+ croak $msg;
+ } # if
+
+ my $attempts = 0;
+ my $maxAttempts = 3;
+ my $sleepTime = 30;
+ my $status;
+
+ # We've been having the server going away. Supposedly it should reconnect so
+ # here we simply retry up to $maxAttempts times to re-execute the statement.
+ # (Are there other places where we need to do this?)
+ $err = 2006;
+
+ while ($err == 2006 and $attempts++ < $maxAttempts) {
+ $status = $sth->execute;
+
+ if ($status) {
+ $err = 0;
+ last;
+ } else {
+ ($err, $msg) = $self->_dberror ('Unable to execute statement',
+ $statement);
+ } # if
+
+ last if $err == 0;
+
+ croak $msg unless $err == 2006;
+
+ my $timestamp = YMDHMS;
+
+ $self->Error ("$timestamp: Unable to talk to DB server.\n\n$msg\n\n"
+ . "Will try again in $sleepTime seconds", -1);
+
+ # Try to reconnect
+ $self->_connect ($self->{dbserver});
+
+ sleep $sleepTime;
+ } # while
+
+ $self->Error ("After $maxAttempts attempts I could not connect to the database", $err)
+ if ($err == 2006 and $attempts > $maxAttempts);
+
+ my @records;
+
+ while (my $row = $sth->fetchrow_hashref) {
+ push @records, $row;
+ } # while
+
+ return @records;
+} # _getRecord
+
+sub _aliasSystem ($) {
+ my ($self, $system) = @_;
+
+ my %system = $self->GetSystem ($system);
+
+ if ($system{name}) {
+ return $system{name};
+ } else {
+ return;
+ } # if
+} # _aliasSystem
+
+sub _getLastID () {
+ my ($self) = @_;
+
+ my $statement = 'select last_insert_id()';
+
+ my $sth = $self->{db}->prepare ($statement);
+
+ my ($err, $msg);
+
+ unless ($sth) {
+ ($err, $msg) = $self->_dberror ('Unable to prepare statement', $statement);
+
+ croak $msg;
+ } # if
+
+ my $status = $sth->execute;
+
+ unless ($status) {
+ ($err, $msg) = $self->_dberror ('Unable to execute statement', $statement);
+
+ croak $msg;
+ } # if
+
+ my @records;
+
+ my @row = $sth->fetchrow_array;
+
+ return $row[0];
+} # _getLastID
+
+sub _connect (;$) {
+ my ($self, $dbserver) = @_;
+
+ $dbserver ||= $CLEAROPTS{CLEARADM_SERVER};
+
+ my $dbname = 'clearadm';
+ my $dbdriver = 'mysql';
+
+ $self->{db} = DBI->connect (
+ "DBI:$dbdriver:$dbname:$dbserver",
+ $CLEAROPTS{CLEARADM_USERNAME},
+ $CLEAROPTS{CLEARADM_PASSWORD},
+ {PrintError => 0},
+ ) or croak (
+ "Couldn't connect to $dbname database "
+ . "as $CLEAROPTS{CLEARADM_USERNAME}\@$CLEAROPTS{CLEARADM_SERVER}"
+ );
+
+ $self->{dbserver} = $dbserver;
+
+ return;
+} # _connect
+
+sub new (;$) {
+ my ($class, $dbserver) = @_;
+
+ my $self = bless {}, $class;
+
+ $self->_connect ($dbserver);
+
+ return $self;
+} # new
+
+sub SetNotify () {
+ my ($self) = @_;
+
+ $self->{NOTIFY} = $CLEAROPTS{CLEARADM_NOTIFY};
+
+ return;
+} # SetNotify
+
+sub Error ($;$) {
+ my ($self, $msg, $errno) = @_;
+
+ # If $errno is specified we need to stop. However we need to notify somebody
+ # that cleartasks is no longer running.
+ error $msg;
+
+ if ($errno) {
+ if ($self->{NOTIFY}) {
+ mail (
+ to => $self->{NOTIFY},
+ subject => 'Internal error occurred in Clearadm',
+ data => "<p>An unexpected, internal error occurred in Clearadm:</p><p>$msg</p>",
+ mode => 'html',
+ );
+
+ exit $errno if $errno > 0;
+ } # if
+ } # if
+
+ return;
+} # Error
+
+sub AddSystem (%) {
+ my ($self, %system) = @_;
+
+ my @requiredFields = (
+ 'name',
+ );
+
+ my $result = _checkRequiredFields \@requiredFields, \%system;
+
+ return -1, "AddSystem: $result"
+ if $result;
+
+ $system{loadavgHist} ||= $defaultLoadavgHist;
+
+ return $self->_addRecord ('system', %system);
+} # AddSystem
+
+sub DeleteSystem ($) {
+ my ($self, $name) = @_;
+
+ return $self->_deleteRecord ('system', "name='$name'");
+} # DeleteSystem
+
+sub UpdateSystem ($%) {
+ my ($self, $name, %update) = @_;
+
+ return $self->_updateRecord ('system', "name='$name'", %update);
+} # UpdateSystem
+
+sub GetSystem ($) {
+ my ($self, $system) = @_;
+
+ return
+ unless $system;
+
+ my @records = $self->_getRecords (
+ 'system',
+ "name='$system' or alias like '%$system%'"
+ );
+
+ if ($records[0]) {
+ return %{$records[0]};
+ } else {
+ return;
+ } # if
+} # GetSystem
+
+sub FindSystem (;$) {
+ my ($self, $system) = @_;
+
+ $system ||= '';
+
+ my $condition = "name like '%$system%' or alias like '%$system%'";
+
+ return $self->_getRecords ('system', $condition);
+} # FindSystem
+
+sub AddPackage (%) {
+ my ($self, %package) = @_;
+
+ my @requiredFields = (
+ 'system',
+ 'name',
+ 'version'
+ );
+
+ my $result = _checkRequiredFields \@requiredFields, \%package;
+
+ return -1, "AddPackage: $result"
+ if $result;
+
+ return $self->_addRecord ('package', %package);
+} # AddPackage
+
+sub DeletePackage ($$) {
+ my ($self, $system, $name) = @_;
+
+ return $self->_deleteRecord (
+ 'package',
+ "(system='$system' or alias='$system') and name='$name'");
+} # DeletePackage
+
+sub UpdatePackage ($$%) {
+ my ($self, $system, $name, %update) = @_;
+
+ $system = $self->_aliasSystem ($system);
+
+ return
+ unless $system;
+
+ return $self->_updateRecord ('package', "system='$system'", %update);
+} # UpdatePackage
+
+sub GetPackage($$) {
+ my ($self, $system, $name) = @_;
+
+ $system = $self->_aliasSystem ($system);
+
+ return
+ unless $system;
+
+ return
+ unless $name;
+
+ my @records = $self->_getRecords (
+ 'package',
+ "system='$system' and name='$name'"
+ );
+
+ if ($records[0]) {
+ return %{$records[0]};
+ } else {
+ return;
+ } # if
+} # GetPackage
+
+sub FindPackage ($;$) {
+ my ($self, $system, $name) = @_;
+
+ $name ||= '';
+
+ $system = $self->_aliasSystem ($system);
+
+ return
+ unless $system;
+
+ my $condition = "system='$system' and name like '%$name%'";
+
+ return $self->_getRecords ('package', $condition);
+} # FindPackage
+
+sub AddFilesystem (%) {
+ my ($self, %filesystem) = @_;
+
+ my @requiredFields = (
+ 'system',
+ 'filesystem',
+ 'fstype'
+ );
+
+ my $result = _checkRequiredFields \@requiredFields, \%filesystem;
+
+ return -1, "AddFilesystem: $result"
+ if $result;
+
+ # Default filesystem threshold
+ $filesystem{threshold} ||= $defaultFilesystemThreshold;
+
+ return $self->_addRecord ('filesystem', %filesystem);
+} # AddFilesystem
+
+sub DeleteFilesystem ($$) {
+ my ($self, $system, $filesystem) = @_;
+
+ $system = $self->_aliasSystem ($system);
+
+ return
+ unless $system;
+
+ return $self->_deleteRecord (
+ 'filesystem',
+ "system='$system' and filesystem='$filesystem'"
+ );
+} # DeleteFilesystem
+
+sub UpdateFilesystem ($$%) {
+ my ($self, $system, $filesystem, %update) = @_;
+
+ $system = $self->_aliasSystem ($system);
+
+ return
+ unless $system;
+
+ return $self->_updateRecord (
+ 'filesystem',
+ "system='$system' and filesystem='$filesystem'",
+ %update
+ );
+} # UpdateFilesystem
+
+sub GetFilesystem ($$) {
+ my ($self, $system, $filesystem) = @_;
+
+ $system = $self->_aliasSystem ($system);
+
+ return
+ unless $system;
+
+ return
+ unless $filesystem;
+
+ my @records = $self->_getRecords (
+ 'filesystem',
+ "system='$system' and filesystem='$filesystem'"
+ );
+
+ if ($records[0]) {
+ return %{$records[0]};
+ } else {
+ return;
+ } # if
+} # GetFilesystem
+
+sub FindFilesystem ($;$) {
+ my ($self, $system, $filesystem) = @_;
+
+ $filesystem ||= '';
+
+ $system = $self->_aliasSystem ($system);
+
+ return
+ unless $system;
+
+ my $condition = "system='$system' and filesystem like '%$filesystem%'";
+
+ return $self->_getRecords ('filesystem', $condition);
+} # FindFilesystem
+
+sub AddVob (%) {
+ my ($self, %vob) = @_;
+
+ my @requiredFields = (
+ 'system',
+ 'tag',
+ );
+
+ my $result = _checkRequiredFields \@requiredFields, \%vob;
+
+ return -1, "AddVob: $result"
+ if $result;
+
+ return $self->_addRecord ('vob', %vob);
+} # AddVob
+
+sub DeleteVob ($) {
+ my ($self, $tag) = @_;
+
+ return $self->_deleteRecord ('vob', "tag='$tag'");
+} # DeleteVob
+
+sub GetVob ($) {
+ my ($self, $tag) = @_;
+
+ return
+ unless $tag;
+
+ my @records = $self->_getRecords ('vob', "tag='$tag'");
+
+ if ($records[0]) {
+ return %{$records[0]};
+ } else {
+ return;
+ } # if
+} # GetVob
+
+sub FindVob ($) {
+ my ($self, $tag) = @_;
+
+ return $self->_getRecords ('vob', "tag like '%$tag%'");
+} # FindVob
+
+sub AddView (%) {
+ my ($self, %view) = @_;
+
+ my @requiredFields = (
+ 'system',
+ 'tag',
+ );
+
+ my $result = _checkRequiredFields \@requiredFields, \%view;
+
+ return -1, "AddView: $result"
+ if $result;
+
+ return $self->_addRecord ('view', %view);
+} # AddView
+
+sub DeleteView ($) {
+ my ($self, $tag) = @_;
+
+ return $self->_deleteRecord ('vob', "tag='$tag'");
+} # DeleteView
+
+sub GetView ($) {
+ my ($self, $tag) = @_;
+
+ return
+ unless $tag;
+
+ my @records = $self->_getRecords ('view', "tag='$tag'");
+
+ if ($records[0]) {
+ return %{$records[0]};
+ } else {
+ return;
+ } # if
+} # GetView
+
+sub FindView (;$$$$) {
+ my ($self, $system, $region, $tag, $ownerName) = @_;
+
+ $system ||= '';
+ $region ||= '';
+ $tag ||= '';
+ $ownerName ||= '';
+
+ my $condition;
+
+ $condition = "system like '%$system%'";
+ $condition .= ' and ';
+ $condition = "region like '%$region%'";
+ $condition .= ' and ';
+ $condition .= "tag like '%$tag'";
+ $condition .= ' and ';
+ $condition .= "ownerName like '%$ownerName'";
+
+ return $self->_getRecords ('view', $condition);
+} # FindView
+
+sub AddFS (%) {
+ my ($self, %fs) = @_;
+
+ my @requiredFields = (
+ 'system',
+ 'filesystem',
+ );
+
+ my $result = _checkRequiredFields \@requiredFields, \%fs;
+
+ return -1, "AddFS: $result"
+ if $result;
+
+ # Timestamp record
+ $fs{timestamp} = Today2SQLDatetime;
+
+ return $self->_addRecord ('fs', %fs);
+} # AddFS
+
+sub TrimFS ($$) {
+ my ($self, $system, $filesystem) = @_;
+
+ my %filesystem = $self->GetFilesystem ($system, $filesystem);
+
+ return
+ unless %filesystem;
+
+ my %task = $self->GetTask ('scrub');
+
+ $self->Error ("Unable to find scrub task!", 1) unless %task;
+
+ my $days;
+ my $today = Today2SQLDatetime;
+
+ # TODO: SubtractDays uses just an approximation (i.e. subtracting 30 days when
+ # in February is not right.
+ if ($filesystem{filesystemHist} =~ /(\d+) month/i) {
+ $days = $1 * 30;
+ } elsif ($filesystem{filesystemHist} =~ /(\d+) year/i) {
+ $days = $1 * 365;
+ } # if
+
+ my $oldage = SubtractDays $today, $days;
+
+ my ($dberr, $dbmsg) = $self->_deleteRecord (
+ 'fs',
+ "system='$system' and filesystem='$filesystem' and timestamp<='$oldage'"
+ );
+
+ if ($dbmsg eq 'Records deleted') {
+ return (0, $dbmsg)
+ if $dberr == 0;
+
+ my %runlog;
+
+ $runlog{task} = $task{name};
+ $runlog{started} = $today;
+ $runlog{status} = 0;
+ $runlog{message} =
+ "Scrubbed $dberr fs records for filesystem $system:$filesystem";
+
+ my ($err, $msg) = $self->AddRunlog (%runlog);
+
+ $self->Error ("Unable to add runlog - (Error: $err)\n$msg") if $err;
+ } # if
+
+ return ($dberr, $dbmsg);
+} # TrimFS
+
+sub TrimLoadavg ($) {
+ my ($self, $system) = @_;
+
+ my %system = $self->GetSystem ($system);
+
+ return
+ unless %system;
+
+ my %task = $self->GetTask ('loadavg');
+
+ $self->Error ("Unable to find loadavg task!", 1) unless %task;
+
+ my $days;
+ my $today = Today2SQLDatetime;
+
+ # TODO: SubtractDays uses just an approximation (i.e. subtracting 30 days when
+ # in February is not right.
+ if ($system{loadavgHist} =~ /(\d+) month/i) {
+ $days = $1 * 30;
+ } elsif ($system{loadavgHist} =~ /(\d+) year/i) {
+ $days = $1 * 365;
+ } # if
+
+ my $oldage = SubtractDays $today, $days;
+
+ my ($dberr, $dbmsg) = $self->_deleteRecord (
+ 'loadavg',
+ "system='$system' and timestamp<='$oldage'"
+ );
+
+ if ($dbmsg eq 'Records deleted') {
+ return (0, $dbmsg)
+ if $dberr == 0;
+
+ my %runlog;
+
+ $runlog{task} = $task{name};
+ $runlog{started} = $today;
+ $runlog{status} = 0;
+ $runlog{message} =
+ "Scrubbed $dberr loadavg records for system $system";
+
+ my ($err, $msg) = $self->AddRunlog (%runlog);
+
+ $self->Error ("Unable to add runload (Error: $err)\n$msg") if $err;
+ } # if
+
+ return ($dberr, $dbmsg);
+} # TrimLoadavg
+
+sub GetFS ($$;$$$$) {
+ my ($self, $system, $filesystem, $start, $end, $count, $interval) = @_;
+
+ $system = $self->_aliasSystem ($system);
+
+ return
+ unless $system;
+
+ return
+ unless $filesystem;
+
+ $interval ||= 'Minute';
+
+ my $size = $interval =~ /month/i
+ ? 7
+ : $interval =~ /day/i
+ ? 10
+ : $interval =~ /hour/i
+ ? 13
+ : 16;
+
+ undef $start if $start and $start =~ /earliest/i;
+ undef $end if $end and $end =~ /latest/i;
+
+ my $condition = "system='$system' and filesystem='$filesystem'";
+ $condition .= " and timestamp>='$start'" if $start;
+ $condition .= " and timestamp<='$end'" if $end;
+
+ $condition .= " group by left(timestamp,$size)";
+
+ if ($count) {
+ # We can't simply do a "limit 0, $count" as that just gets the front end of
+ # the records return (i.e. if $count = say 10 and the timestamp range
+ # returns 40 rows we'll see only rows 1-10, not rows 31-40). We need limit
+ # $offset, $count where $offset = the number of qualifying records minus
+ # $count
+ my $nbrRecs = $self->Count ('fs', $condition);
+ my $offset = $nbrRecs - $count;
+
+ # Offsets of < 0 are not allowed.
+ $offset = 0
+ if $offset < 0;
+
+ $condition .= " limit $offset, $count";
+ } # if
+
+ my $statement = <<"END";
+select
+ system,
+ filesystem,
+ mount,
+ left(timestamp,$size) as timestamp,
+ avg(size) as size,
+ avg(used) as used,
+ avg(free) as free,
+ reserve
+from
+ fs
+ where $condition
+END
+
+ my ($err, $msg);
+
+ my $sth = $self->{db}->prepare ($statement);
+
+ unless ($sth) {
+ ($err, $msg) = $self->_dberror ('Unable to prepare statement', $statement);
+
+ croak $msg;
+ } # if
+
+ my $status = $sth->execute;
+
+ unless ($status) {
+ ($err, $msg) = $self->_dberror ('Unable to execute statement', $statement);
+
+ croak $msg;
+ } # if
+
+ my @records;
+
+ while (my $row = $sth->fetchrow_hashref) {
+ push @records, $row;
+ } # while
+
+ return @records;
+} # GetFS
+
+sub GetLatestFS ($$) {
+ my ($self, $system, $filesystem) = @_;
+
+ $system = $self->_aliasSystem ($system);
+
+ return
+ unless $system;
+
+ return
+ unless $filesystem;
+
+ my @records = $self->_getRecords (
+ 'fs',
+ "system='$system' and filesystem='$filesystem'"
+ . " order by timestamp desc limit 0, 1",
+ );
+
+ if ($records[0]) {
+ return %{$records[0]};
+ } else {
+ return;
+ } # if
+} # GetLatestFS
+
+sub AddLoadavg () {
+ my ($self, %loadavg) = @_;
+
+ my @requiredFields = (
+ 'system',
+ );
+
+ my $result = _checkRequiredFields \@requiredFields, \%loadavg;
+
+ return -1, "AddLoadavg: $result"
+ if $result;
+
+ # Timestamp record
+ $loadavg{timestamp} = Today2SQLDatetime;
+
+ return $self->_addRecord ('loadavg', %loadavg);
+} # AddLoadavg
+
+sub GetLoadavg ($;$$$$) {
+ my ($self, $system, $start, $end, $count, $interval) = @_;
+
+ $system = $self->_aliasSystem ($system);
+
+ return
+ unless $system;
+
+ $interval ||= 'Minute';
+
+ my $size = $interval =~ /month/i
+ ? 7
+ : $interval =~ /day/i
+ ? 10
+ : $interval =~ /hour/i
+ ? 13
+ : 16;
+
+ my $condition;
+
+ undef $start if $start and $start =~ /earliest/i;
+ undef $end if $end and $end =~ /latest/i;
+
+ $condition .= " system='$system'" if $system;
+ $condition .= " and timestamp>='$start'" if $start;
+ $condition .= " and timestamp<='$end'" if $end;
+
+ $condition .= " group by left(timestamp,$size)";
+
+ if ($count) {
+ # We can't simply do a "limit 0, $count" as that just gets the front end of
+ # the records return (i.e. if $count = say 10 and the timestamp range
+ # returns 40 rows we'll see only rows 1-10, not rows 31-40). We need limit
+ # $offset, $count where $offset = the number of qualifying records minus
+ # $count
+ my $nbrRecs = $self->Count ('loadavg', $condition);
+ my $offset = $nbrRecs - $count;
+
+ # Offsets of < 0 are not allowed.
+ $offset = 0
+ if $offset < 0;
+
+ $condition .= " limit $offset, $count";
+ } # if
+
+ my $statement = <<"END";
+select
+ system,
+ left(timestamp,$size) as timestamp,
+ uptime,
+ users,
+ avg(loadavg) as loadavg
+from
+ loadavg
+ where $condition
+END
+
+ my ($err, $msg);
+
+ my $sth = $self->{db}->prepare ($statement);
+
+ unless ($sth) {
+ ($err, $msg) = $self->_dberror ('Unable to prepare statement', $statement);
+
+ croak $msg;
+ } # if
+
+ my $status = $sth->execute;
+
+ unless ($status) {
+ ($err, $msg) = $self->_dberror ('Unable to execute statement', $statement);
+
+ croak $msg;
+ } # if
+
+ my @records;
+
+ while (my $row = $sth->fetchrow_hashref) {
+ push @records, $row;
+ } # while
+
+ return @records;
+} # GetLoadvg
+
+sub GetLatestLoadavg ($) {
+ my ($self, $system) = @_;
+
+ $system = $self->_aliasSystem ($system);
+
+ return
+ unless $system;
+
+ my @records = $self->_getRecords (
+ 'loadavg',
+ "system='$system'"
+ . " order by timestamp desc limit 0, 1",
+ );
+
+ if ($records[0]) {
+ return %{$records[0]};
+ } else {
+ return;
+ } # if
+} # GetLatestLoadavg
+
+sub AddTask (%) {
+ my ($self, %task) = @_;
+
+ my @requiredFields = (
+ 'name',
+ 'command'
+ );
+
+ my $result = _checkRequiredFields \@requiredFields, \%task;
+
+ return -1, "AddTask: $result"
+ if $result;
+
+ return $self->_addRecord ('task', %task);
+} # AddTask
+
+sub DeleteTask ($) {
+ my ($self, $name) = @_;
+
+ return $self->_deleteRecord ('task', "name='$name'");
+} # DeleteTask
+
+sub FindTask ($) {
+ my ($self, $name) = @_;
+
+ $name ||= '';
+
+ my $condition = "name like '%$name%'";
+
+ return $self->_getRecords ('task', $condition);
+} # FindTask
+
+sub GetTask ($) {
+ my ($self, $name) = @_;
+
+ return
+ unless $name;
+
+ my @records = $self->_getRecords ('task', "name='$name'");
+
+ if ($records[0]) {
+ return %{$records[0]};
+ } else {
+ return;
+ } # if
+} # GetTask
+
+sub UpdateTask ($%) {
+ my ($self, $name, %update) = @_;
+
+ return $self->_updateRecord ('task', "name='$name'", %update);
+} # Update
+
+sub AddSchedule (%) {
+ my ($self, %schedule) = @_;
+
+ my @requiredFields = (
+ 'task',
+ );
+
+ my $result = _checkRequiredFields \@requiredFields, \%schedule;
+
+ return -1, "AddSchedule: $result"
+ if $result;
+
+ return $self->_addRecord ('schedule', %schedule);
+} # AddSchedule
+
+sub DeleteSchedule ($) {
+ my ($self, $name) = @_;
+
+ return $self->_deleteRecord ('schedule', "name='$name'");
+} # DeleteSchedule
+
+sub FindSchedule (;$$) {
+ my ($self, $name, $task) = @_;
+
+ $name ||= '';
+ $task||= '';
+
+ my $condition = "name like '%$name%'";
+ $condition .= ' and ';
+ $condition .= "task like '%$task%'";
+
+ return $self->_getRecords ('schedule', $condition);
+} # FindSchedule
+
+sub GetSchedule ($) {
+ my ($self, $name) = @_;
+
+ my @records = $self->_getRecords ('schedule', "name='$name'");
+
+ if ($records[0]) {
+ return %{$records[0]};
+ } else {
+ return;
+ } # if
+} # GetSchedule
+
+sub UpdateSchedule ($%) {
+ my ($self, $name, %update) = @_;
+
+ return $self->_updateRecord ('schedule', "name='$name'", %update);
+} # UpdateSchedule
+
+sub AddRunlog (%) {
+ my ($self, %runlog) = @_;
+
+ my @requiredFields = (
+ 'task',
+ );
+
+ my $result = _checkRequiredFields \@requiredFields, \%runlog;
+
+ return -1, "AddRunlog: $result"
+ if $result;
+
+ $runlog{ended} = Today2SQLDatetime;
+
+ my ($err, $msg) = $self->_addRecord ('runlog', %runlog);
+
+ return ($err, $msg, $self->_getLastID);
+} # AddRunlog
+
+sub DeleteRunlog ($) {
+ my ($self, $condition) = @_;
+
+ return $self->_deleteRecord ('runlog', $condition);
+} # DeleteRunlog
+
+sub FindRunlog (;$$$$$$) {
+ my ($self, $task, $system, $status, $id, $start, $page) = @_;
+
+ $task ||= '';
+
+ # If ID is specified then that's all that really matters as it uniquely
+ # identifies a runlog entry;
+ my $condition;
+
+ unless ($id) {
+ $condition = "task like '%$task%'";
+
+ if ($system) {
+ $condition .= " and system like '%$system%'"
+ unless $system eq 'All';
+ } else {
+ $condition .= ' and system is null';
+ } # unless
+
+ if (defined $status) {
+ if ($status =~ /!(-*\d+)/) {
+ $condition .= " and status<>$1";
+ } else {
+ $condition .= " and status=$status"
+ } # if
+ } # if
+
+ $condition .= " order by started desc";
+
+ if (defined $start) {
+ $page ||= 10;
+ $condition .= " limit $start, $page";
+ } # unless
+ } else {
+ $condition = "id=$id";
+ } # unless
+
+ return $self->_getRecords ('runlog', $condition);
+} # FindRunlog
+
+sub GetRunlog ($) {
+ my ($self, $id) = @_;
+
+ return
+ unless $id;
+
+ my @records = $self->_getRecords ('runlog', "id=$id");
+
+ if ($records[0]) {
+ return %{$records[0]};
+ } else {
+ return;
+ } # if
+} # GetRunlog
+
+sub UpdateRunlog ($%) {
+ my ($self, $id, %update) = @_;
+
+ return $self->_updateRecord ('runlog', "id=$id", %update);
+} # UpdateRunlog
+
+sub Count ($;$) {
+ my ($self, $table, $condition) = @_;
+
+ $condition = $condition ? 'where ' . $condition : '';
+
+ my ($err, $msg);
+
+ my $statement = "select count(*) from $table $condition";
+
+ my $sth = $self->{db}->prepare ($statement);
+
+ unless ($sth) {
+ ($err, $msg) = $self->_dberror ('Unable to prepare statement', $statement);
+
+ croak $msg;
+ } # if
+
+ my $status = $sth->execute;
+
+ unless ($status) {
+ ($err, $msg) = $self->_dberror ('Unable to execute statement', $statement);
+
+ croak $msg;
+ } # if
+
+ # Hack! Statements such as the following:
+ #
+ # select count(*) from fs where system='jupiter' and filesystem='/dev/sdb5'
+ # > group by left(timestamp,10);
+ # +----------+
+ # | count(*) |
+ # +----------+
+ # | 49 |
+ # | 98 |
+ # | 140 |
+ # | 7 |
+ # | 74 |
+ # | 124 |
+ # | 190 |
+ # +----------+
+ # 7 rows in set (0.00 sec)
+ #
+ # Here we want 7 but what we see in $records[0] is 49. So the hack is that if
+ # statement contains "group by" then we assume we have the above and return
+ # scalar @records, otherwise we return $records[0];
+ if ($statement =~ /group by/i) {
+ my $allrows = $sth->fetchall_arrayref;
+
+ return scalar @{$allrows};
+ } else {
+ my @records = $sth->fetchrow_array;
+
+ return $records[0];
+ } # if
+} # Count
+
+# GetWork returns two items, the number of seconds to wait before the next task
+# and array of hash records of work to be done immediately. The caller should
+# execute the work to be done, timing it, and subtracting it from the $sleep
+# time returned. If the caller exhausts the $sleep time then they should call
+# us again.
+sub GetWork () {
+ my ($self) = @_;
+
+ my ($err, $msg);
+
+ my $statement = <<"END";
+select
+ schedule.name as schedulename,
+ task.name,
+ task.system as system,
+ task.command,
+ schedule.notification,
+ frequency,
+ runlog.started as lastrun
+from
+ task,
+ schedule left join runlog on schedule.lastrunid=runlog.id
+where
+ schedule.task=task.name
+ and schedule.active='true'
+order by lastrun
+END
+
+ my $sth = $self->{db}->prepare ($statement);
+
+ unless ($sth) {
+ ($err, $msg) = $self->_dberror ('Unable to prepare statement', $statement);
+
+ croak $msg;
+ } # if
+
+ my $status = $sth->execute;
+
+ unless ($status) {
+ ($err, $msg) = $self->_dberror ('Unable to execute statement', $statement);
+
+ croak $msg;
+ } # if
+
+ my $sleep;
+ my @records;
+
+ while (my $row = $sth->fetchrow_hashref) {
+ if ($$row{system} !~ /localhost/i) {
+ my %system = $self->GetSystem ($$row{system});
+
+ # Skip inactive systems
+ next if $system{active} eq 'false';
+ } # if
+
+ # If started is not defined then this task was never run so run it now.
+ unless ($$row{lastrun}) {
+ push @records, $row;
+ next;
+ } # unless
+
+ # TODO: Handle frequencies better.
+ my $seconds;
+
+ if ($$row{frequency} =~ /(\d+) seconds/i) {
+ $seconds = $1;
+ } elsif ($$row{frequency} =~ /(\d+) minute/i) {
+ $seconds = $1 * 60;
+ } elsif ($$row{frequency} =~ /(\d+) hour/i) {
+ $seconds = $1 * 60 * 60;
+ } elsif ($$row{frequency} =~ /(\d+) day/i) {
+ $seconds= $1 * 60 * 60 * 24;
+ } else {
+ warning "Don't know how to handle frequencies like $$row{frequency}";
+ next;
+ } # if
+
+ my $today = Today2SQLDatetime;
+ my $lastrun = Add ($$row{lastrun}, (seconds => $seconds));
+ my $waitTime = DateToEpoch ($lastrun) - DateToEpoch ($today);
+
+ if ($waitTime < 0) {
+ # We're late - push this onto records and move on
+ push @records, $row;
+ } # if
+
+ $sleep ||= $waitTime;
+
+ if ($sleep > $waitTime) {
+ $sleep = $waitTime;
+ } # if
+ } # while
+
+ # Even if there is nothing to do the caller should sleep a bit and come back
+ # to us. So if it ends up there's nothing past due, and nothing upcoming, then
+ # sleep for a minute and return here. Somebody may have added a new task next
+ # time we're called.
+ if (@records == 0 and not $sleep) {
+ $sleep = 60;
+ } # if
+
+ return ($sleep, @records);
+} # GetWork
+
+sub GetUniqueList ($$) {
+ my ($self, $table, $field) = @_;
+
+ my ($err, $msg);
+
+ my $statement = "select $field from $table group by $field";
+
+ my $sth = $self->{db}->prepare ($statement);
+
+ unless ($sth) {
+ ($err, $msg) = $self->_dberror ('Unable to prepare statement', $statement);
+
+ croak $msg;
+ } # if
+
+ my $status = $sth->execute;
+
+ unless ($status) {
+ ($err, $msg) = $self->_dberror ('Unable to execute statement', $statement);
+
+ croak $msg;
+ } # if
+
+ my @values;
+
+ while (my @row = $sth->fetchrow_array) {
+ if ($row[0]) {
+ push @values, $row[0];
+ } else {
+ push @values, '<NULL>';
+ } # if
+ } # foreach
+
+ return @values;
+} # GetUniqueList
+
+sub AddAlert(%) {
+ my ($self, %alert) = @_;
+
+ my @requiredFields = (
+ 'name',
+ 'type',
+ );
+
+ my $result = _checkRequiredFields \@requiredFields, \%alert;
+
+ return -1, "AddAlert: $result"
+ if $result;
+
+ return $self->_addRecord ('alert', %alert);
+} # AddAlert
+
+sub DeleteAlert ($) {
+ my ($self, $name) = @_;
+
+ return $self->_deleteRecord ('alert', "name='$name'");
+} # DeleteAlert
+
+sub FindAlert (;$) {
+ my ($self, $alert) = @_;
+
+ $alert ||= '';
+
+ my $condition = "name like '%$alert%'";
+
+ return $self->_getRecords ('alert', $condition);
+} # FindAlert
+
+sub GetAlert ($) {
+ my ($self, $name) = @_;
+
+ return
+ unless $name;
+
+ my @records = $self->_getRecords ('alert', "name='$name'");
+
+ if ($records[0]) {
+ return %{$records[0]};
+ } else {
+ return;
+ } # if
+} # GetAlert
+
+sub SendAlert ($$$$$$$) {
+ my (
+ $self,
+ $alert,
+ $system,
+ $notification,
+ $subject,
+ $message,
+ $to,
+ $runlogID,
+ ) = @_;
+
+ my $footing = '<hr><p style="text-align: center;">';
+ $footing .= '<font color="#bbbbbb">';
+ my $year = (localtime)[5] + 1900;
+ $footing .= "<a href='$CLEAROPTS{CLEARADM_WEBBASE}'>Clearadm</a><br>";
+ $footing .= "Copyright © $year, ClearSCM, Inc. - All rights reserved";
+
+ my %alert = $self->GetAlert ($alert);
+
+ if ($alert{type} eq 'email') {
+ my $from = 'Clearadm@' . hostdomain;
+
+ mail (
+ from => $from,
+ to => $to,
+ subject => "Clearadm Alert: $system: $subject",
+ mode => 'html',
+ data => $message,
+ footing => $footing,
+ );
+ } else {
+ $self->Error ("Don't know how to send $alert{type} alerts\n"
+ . "Subject: $subject\n"
+ . "Message: $message", 1);
+ } # if
+
+ # Log alert
+ my %alertlog = (
+ alert => $alert,
+ system => $system,
+ notification => $notification,
+ runlog => $runlogID,
+ timestamp => Today2SQLDatetime,
+ message => $subject,
+ );
+
+ return $self->AddAlertlog (%alertlog);
+} # SendAlert
+
+sub GetLastAlert ($$) {
+ my ($self, $notification, $system) = @_;
+
+ my $statement = <<"END";
+select
+ runlog,
+ timestamp
+from
+ alertlog
+where
+ notification='$notification'
+ and system='$system'
+order by
+ timestamp desc
+limit
+ 0, 1
+END
+
+ my $sth = $self->{db}->prepare ($statement)
+ or return $self->_dberror ('Unable to prepare statement', $statement);
+
+ $sth->execute
+ or return $self->_dberror ('Unable to execute statement', $statement);
+
+ my $alertlog= $sth->fetchrow_hashref;
+
+ $sth->finish;
+
+ if ($alertlog) {
+ return %$alertlog;
+ } else {
+ return;
+ } # if
+} # GetLastAlert
+
+sub GetLastTaskFailure ($$) {
+ my ($self, $task, $system) = @_;
+
+ my $statement = <<"END";
+select
+ id,
+ ended
+from
+ runlog
+where
+ status <> 0
+ and task='$task'
+ and system='$system'
+ and alerted='true'
+order by
+ ended desc
+limit
+ 0, 1
+END
+
+ my $sth = $self->{db}->prepare ($statement)
+ or return $self->_dberror ('Unable to prepare statement', $statement);
+
+ $sth->execute
+ or return $self->_dberror ('Unable to execute statement', $statement);
+
+ my $runlog= $sth->fetchrow_hashref;
+
+ $sth->finish;
+
+ if ($$runlog{ended}) {
+ return %$runlog;
+ } # if
+
+ # If we didn't get any ended in the last call then there's nothing that
+ # qualified. Still let's return a record (%runlog) that has a valid id so
+ # that the caller can update that runlog with alerted = 'true'.
+ $statement = <<"END";
+select
+ id
+from
+ runlog
+where
+ status <> 0
+ and task='$task'
+ and system='$system'
+order by
+ ended desc
+limit
+ 0, 1
+END
+
+ $sth = $self->{db}->prepare ($statement)
+ or return $self->_dberror ('Unable to prepare statement', $statement);
+
+ $sth->execute
+ or return $self->_dberror ('Unable to execute statement', $statement);
+
+ $runlog = $sth->fetchrow_hashref;
+
+ $sth->finish;
+
+ if ($runlog) {
+ return %$runlog;
+ } else {
+ return
+ } # if
+} # GetLastTaskFailure
+
+sub Notify ($$$$$$) {
+ my (
+ $self,
+ $notification,
+ $subject,
+ $message,
+ $task,
+ $system,
+ $filesystem,
+ $runlogID,
+ ) = @_;
+
+ $runlogID = $self->_getLastID
+ unless $runlogID;
+
+ my ($err, $msg);
+
+ # Update filesystem, if $filesystem was specified
+ if ($filesystem) {
+ ($err, $msg) = $self->UpdateFilesystem (
+ $system,
+ $filesystem, (
+ notification => $notification,
+ ),
+ );
+
+ $self->Error ("Unable to set notification for filesystem $system:$filesystem "
+ . "(Status: $err)\n$msg", $err) if $err;
+ } # if
+
+ # Update system
+ ($err, $msg) = $self->UpdateSystem (
+ $system, (
+ notification => $notification,
+ ),
+ );
+
+ my %notification = $self->GetNotification ($notification);
+
+ my %lastnotified = $self->GetLastAlert ($notification, $system);
+
+ if (%lastnotified and $lastnotified{timestamp}) {
+ my $today = Today2SQLDatetime;
+ my $lastnotified = $lastnotified{timestamp};
+
+ if ($notification{nomorethan} =~ /hour/i) {
+ $lastnotified = Add ($lastnotified, (hours => 1));
+ } elsif ($notification{nomorethan} =~ /day/i) {
+ $lastnotified = Add ($lastnotified, (days => 1));
+ } elsif ($notification{nomorethan} =~ /week/i) {
+ $lastnotified = Add ($lastnotified, (days => 7));
+ } elsif ($notification{nomorethan} =~ /month/i) {
+ $lastnotified = Add ($lastnotified, (month => 1));
+ } # if
+
+ # If you want to fake an alert in the debugger just change $diff accordingly
+ my $diff = Compare ($today, $lastnotified);
+
+ return
+ if $diff <= 0;
+ } # if
+
+ my $when = Today2SQLDatetime;
+ my $nomorethan = lc $notification{nomorethan};
+ my %alert = $self->GetAlert ($notification{alert});
+ my $to = $alert{who};
+
+ # If $to is null then this means to send the alert to the admin for the
+ # machine.
+ unless ($to) {
+ if ($system) {
+ my %system = $self->GetSystem ($system);
+
+ $to = $system{email};
+ } else {
+ # If we don't know what system this error occurred on we'll have to notify
+ # the "super user" defined as $self->{NOTIFY} (The receiver of last
+ # resort)
+ $to = $self->{NOTIFY};
+ } # if
+ } # unless
+
+ unless ($to) {
+ Error "To undefined";
+ } # unless
+
+ $message .= "<p>You will receive this alert no more than $nomorethan.</p>";
+
+ ($err, $msg) = $self->SendAlert (
+ $notification{alert},
+ $system,
+ $notification{name},
+ $subject,
+ $message,
+ $to,
+ $runlogID,
+ );
+
+ $self->Error ("Unable to send alert (Status: $err)\n$msg", $err) if $err;
+
+ verbose "Sent alert to $to";
+
+ # Update runlog to indicate we notified the user for this execution
+ ($err, $msg) = $self->UpdateRunlog (
+ $runlogID, (
+ alerted => 'true',
+ ),
+ );
+
+ $self->Error ("Unable to update runlog (Status: $err)\n$msg", $err) if $err;
+
+ return;
+} # Notify
+
+sub ClearNotifications ($$;$) {
+ my ($self, $system, $filesystem) = @_;
+
+ my ($err, $msg);
+
+ if ($filesystem) {
+ ($err, $msg) = $self->UpdateFilesystem (
+ $system,
+ $filesystem, (notification => undef),
+ );
+
+ error "Unable to clear notification for filesystem $system:$filesystem "
+ . "(Status: $err)\n$msg", $err
+ if $err;
+
+ # Check to see any of this system's filesystems have notifications. If none
+ # then it's save to say we've turned off the last notification for a
+ # filesystem involved with this system and if $system{notification} was
+ # 'Filesystem' then we can toggle off the notification on the system too
+ my $filesystemsAlerted = 0;
+
+ foreach ($self->FindFilesystem ($system)) {
+ $filesystemsAlerted++
+ if $$_{notification};
+ } # foreach
+
+ my %system = $self->GetSystem ($system);
+
+ return
+ unless $system;
+
+ if ($system{notification} and
+ $system{notification} eq 'Filesystem' and
+ $filesystemsAlerted == 0) {
+ ($err, $msg) = $self->UpdateSystem ($system, (notification => undef));
+
+ $self->Error ("Unable to clear notification for system $system "
+ . "(Status: $err)\n$msg", $err) if $err;
+ } # if
+ } else {
+ ($err, $msg) = $self->UpdateSystem ($system, (notification => undef));
+
+ $self->Error ("Unable to clear notification for system $system "
+ . "(Status: $err)\n$msg", $err) if $err;
+ } # if
+
+ return;
+} # ClearNotifications
+
+sub SystemAlive (%) {
+ my ($self, %system) = @_;
+
+ # If we've never heard from this system then we will assume that the system
+ # has not been set up to run clearagent and has never checked in. In any event
+ # we cannot say the system died because we've never known it to be alive!
+ return 1
+ unless $system{lastheardfrom};
+
+ # If a system is not active (may have been temporarily been deactivated) then
+ # we don't want to turn on the bells and whistles alerting people it's down.
+ return 1
+ if $system{active} eq 'false';
+
+ my $today = Today2SQLDatetime;
+ my $lastheardfrom = $system{lastheardfrom};
+
+ my $tenMinutes = 10 * 60;
+
+ $lastheardfrom = Add ($lastheardfrom, (seconds => $tenMinutes));
+
+ if (DateToEpoch ($lastheardfrom) < DateToEpoch ($today)) {
+ $self->UpdateSystem (
+ $system{name}, (
+ notification => 'Heartbeat'
+ ),
+ );
+
+ return;
+ } else {
+ if ($system{notification}) {
+ $self->UpdateSystem (
+ $system{name}, (
+ notification => undef
+ ),
+ );
+ }
+ return 1;
+ } # if
+} # SystemAlive
+
+sub UpdateAlert ($%) {
+ my ($self, $name, %update) = @_;
+
+ return $self->_updateRecord (
+ 'alert',
+ "name='$name'",
+ %update
+ );
+} # UpdateAlert
+
+sub AddAlertlog (%) {
+ my ($self, %alertlog) = @_;
+
+ my @requiredFields = (
+ 'alert',
+ 'notification',
+ );
+
+ my $result = _checkRequiredFields \@requiredFields, \%alertlog;
+
+ return -1, "AddAlertlog: $result"
+ if $result;
+
+ # Timestamp record
+ $alertlog{timestamp} = Today2SQLDatetime;
+
+ return $self->_addRecord ('alertlog', %alertlog);
+} # AddAlertlog
+
+sub DeleteAlertlog ($) {
+ my ($self, $condition) = @_;
+
+ return
+ unless $condition;
+
+ if ($condition =~ /all/i) {
+ return $self->_deleteRecord ('alertlog');
+ } else {
+ return $self->_deleteRecord ('alertlog', $condition);
+ } # if
+} # DeleteAlertlog
+
+sub FindAlertlog (;$$$$$) {
+ my ($self, $alert, $system, $notification, $start, $page) = @_;
+
+ $alert ||= '';
+ $system ||= '';
+ $notification ||= '';
+
+ my $condition = "alert like '%$alert%'";
+ $condition .= ' and ';
+ $condition .= "system like '%$system%'";
+ $condition .= ' and ';
+ $condition .= "notification like '%$notification%'";
+ $condition .= " order by timestamp desc";
+
+ if (defined $start) {
+ $page ||= 10;
+ $condition .= " limit $start, $page";
+ } # unless
+
+ return $self->_getRecords ('alertlog', $condition);
+} # FindAlertLog
+
+sub GetAlertlog ($) {
+ my ($self, $alert) = @_;
+
+ return
+ unless $alert;
+
+ my @records = $self->_getRecords ('alertlog', "alert='$alert'");
+
+ if ($records[0]) {
+ return %{$records[0]};
+ } else {
+ return;
+ } # if
+} # GetAlertlog
+
+sub UpdateAlertlog ($%) {
+ my ($self, $alert, %update) = @_;
+
+ return $self->_updateRecord (
+ 'alertlog',
+ "alert='$alert'",
+ %update
+ );
+} # UpdateAlertlog
+
+sub AddNotification (%) {
+ my ($self, %notification) = @_;
+
+ my @requiredFields = (
+ 'name',
+ 'alert',
+ 'cond'
+ );
+
+ my $result = _checkRequiredFields \@requiredFields, \%notification;
+
+ return -1, "AddNotification: $result"
+ if $result;
+
+ return $self->_addRecord ('notification', %notification);
+} # AddNotification
+
+sub DeleteNotification ($) {
+ my ($self, $name) = @_;
+
+ return $self->_deleteRecord ('notification', "name='$name'");
+} # DeletePackage
+
+sub FindNotification (;$$) {
+ my ($self, $name, $cond, $ordering) = @_;
+
+ $name ||= '';
+
+ my $condition = "name like '%$name%'";
+ $condition .= " and $cond"
+ if $cond;
+
+ return $self->_getRecords ('notification', $condition);
+} # FindNotification
+
+sub GetNotification ($) {
+ my ($self, $name) = @_;
+
+ return
+ unless $name;
+
+ my @records = $self->_getRecords ('notification', "name='$name'");
+
+ if ($records[0]) {
+ return %{$records[0]};
+ } else {
+ return;
+ } # if
+} # GetNotification
+
+sub UpdateNotification ($%) {
+ my ($self, $name, %update) = @_;
+
+ return $self->_updateRecord (
+ 'notification',
+ "name='$name'",
+ %update
+ );
+} # UpdateNotification
+
+1;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<Carp>
+
+L<DBI>
+
+L<FindBin>
+
+L<Net::Domain|Net::Domain>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ DateUtils
+ Display
+ GetConfig
+ Mail
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/DateUtils.pm">DateUtils</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/GetConfig.pm">GetConfig</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Mail.pm">Mail</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this module
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2010, ClearSCM, Inc. All rights reserved.
+
+=cut
--- /dev/null
+=pod
+
+=head1 NAME $RCSfile: ClearadmWeb.pm,v $
+
+Common routines for the web portion of Clearadm
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.46 $
+
+=item Created
+
+Sat Dec 18 08:43:27 EST 2010
+
+=item Modified
+
+$Date: 2011/12/26 19:00:58 $
+
+=back
+
+=head1 SYNOPSIS
+
+This module holds common web routines for the web portion of Clearadm.
+
+=head1 DESCRIPTION
+
+To be filled out.
+
+=head1 ROUTINES
+
+The following routines are exported:
+
+=cut
+
+package ClearadmWeb;
+
+use warnings;
+use strict;
+
+use base 'Exporter';
+
+use CGI qw (
+ :standard
+ start_a
+ end_a
+ start_div
+ end_div
+ start_li
+ end_li
+ start_table
+ end_table
+ start_td
+ end_td
+ start_Tr
+ end_Tr
+ start_ul
+ end_ul
+);
+
+use Carp;
+use File::Basename;
+
+use FindBin;
+
+use lib "$FindBin::Bin/../../lib";
+
+use Clearadm;
+use DateUtils;
+use Display;
+use Utils;
+
+my $clearadm = Clearadm->new;
+
+our $APPNAME= 'Clearadm';
+our $VERSION = '$Revision: 1.46 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+our @EXPORT = qw (
+ autoScale
+ displayError
+ displayAlert
+ displayAlertlog
+ displayFilesystem
+ displayNotification
+ displayRunlog
+ displaySchedule
+ displaySystem
+ displayTask
+ dbug
+ dumpVars
+ editAlert
+ editFilesystem
+ editNotification
+ editSchedule
+ editSystem
+ editTask
+ footing
+ graphError
+ heading
+ makeAlertDropdown
+ makeFilesystemDropdown
+ makeIntervalDropdown
+ makeNotificationDropdown
+ makeSystemDropdown
+ makeTimeDropdown
+ makeTaskDropdown
+ setField
+ setFields
+);
+
+our @PREDEFINED_ALERTS = (
+ 'Email admin',
+);
+
+our @PREDEFINED_NOTIFICATIONS = (
+ 'Loadavg',
+ 'Filesystem',
+ 'Scrub',
+ 'Heartbeat',
+ 'System checkin',
+ 'Update systems',
+);
+
+our @PREDEFINED_TASKS = (
+ 'Loadavg',
+ 'Filesystem',
+ 'Scrub',
+ 'System checkin',
+ 'Update systems',
+);
+
+our @PREDEFINED_SCHEDULES = (
+ 'Loadavg',
+ 'Filesystem',
+ 'Scrub',
+ 'Update systems',
+);
+
+our @PREDEFINED_NOTMORETHAN = (
+ 'Once an hour',
+ 'Once a day',
+ 'Once a week',
+ 'Once a month',
+);
+
+our @PREDEFINED_MULTIPLIERS = (
+ 'Seconds',
+ 'Minutes',
+ 'Hours',
+ 'Days',
+);
+
+sub dbug ($) {
+ my ($msg) = @_;
+
+ display font ({-class => 'error'}, '<br>DEBUG: '). $msg;
+
+ return;
+} # dbug
+
+sub displayError ($) {
+ my ($msg) = @_;
+
+ display font ({-class => 'error'}, 'Error: ') . $msg;
+
+ return
+} # displayError;
+
+sub setField ($;$) {
+ my ($field, $label) = @_;
+
+ $label ||= 'Unknown';
+
+ my $undef = font {-class => 'unknown'}, $label;
+
+ return defined $field ? $field : $undef;
+} # setField
+
+sub setFields ($%) {
+ my ($label, %rec) = @_;
+
+ $rec{$_} = setField ($rec{$_}, $label)
+ foreach keys %rec;
+
+ return %rec;
+} # setFields;
+
+sub dumpVars (%) {
+ my (%vars) = @_;
+
+ foreach (keys %vars) {
+ dbug "$_: $vars{$_}";
+ } # foreach
+
+ return;
+} # dumpVars
+
+sub graphError ($) {
+ my ($msg) = @_;
+
+ use GD;
+
+ # Make the image fit the message. It seems that characters are ~ 7px wide.
+ my $imageLength = length ($msg) * 7;
+
+ my $errorImage = GD::Image->new ($imageLength, 20);
+
+ # Allocate some colors
+ my $white = $errorImage->colorAllocate (255, 255, 255);
+ my $red = $errorImage->colorAllocate (255, 0, 0);
+
+ # Allow the text to shine through
+ $errorImage->transparent($white);
+ $errorImage->interlaced('true');
+
+ # Now put out the message
+ $errorImage->string (gdMediumBoldFont, 0, 0, $msg, $red);
+
+ # And return it
+ print "Content-type: image/png\n\n";
+ print $errorImage->png;
+
+ # Since we've "returned" the error in the form of an image, there's nothing
+ # left for us to do so we can exit
+ exit;
+} # graphError
+
+sub autoScale ($) {
+ my ($amount) = @_;
+
+ my $kbyte = 1024;
+ my $meg = (1024 * $kbyte);
+ my $gig = (1024 * $meg);
+
+ my $size = $amount > $gig
+ ? sprintf ('%.2f Gig', $amount / $gig)
+ : $amount > $meg
+ ? sprintf ('%.2f Meg', $amount / $meg)
+ : sprintf ('%.2f Kbyte', $amount / $kbyte);
+
+ return $size;
+} # autoScale
+
+sub _makeAlertlogSelection ($$) {
+ my ($name, $default) = @_;
+
+ $default ||= 'All';
+
+ my %values;
+
+ $values{All} = 'All';
+
+ $values{$$_{$name}} = $$_{$name}
+ foreach ($clearadm->FindAlertlog);
+
+ my $dropdown = popup_menu {
+ name => $name,
+ class => 'dropdown',
+ values => [sort keys %values],
+ default => $default,
+ };
+
+ return $dropdown;
+} # _makeAlertlogSelection
+
+sub _makeRunlogSelection ($$) {
+ my ($name, $default) = @_;
+
+ $default ||= 'All';
+
+ my @values = sort $clearadm->GetUniqueList ('runlog', $name);
+
+ unshift @values, 'All';
+
+ my %values;
+
+ foreach (@values) {
+ unless ($_ eq '') {
+ $values{$_} = $_;
+ } else {
+ $values{NULL} = '<NULL>';
+ } #if
+ } # foreach
+
+ my $dropdown = popup_menu {
+ name => $name,
+ class => 'dropdown',
+ values => \@values,
+ default => $default,
+ labels => \%values,
+ };
+
+ return $dropdown;
+} # _makeRunlogSelection
+
+sub _makeRunlogSelectionNumeric ($$) {
+ my ($name, $default) = @_;
+
+ $default ||= 'All';
+
+ my @values = sort {$a <=> $b} $clearadm->GetUniqueList ('runlog', $name);
+
+ unshift @values, 'All';
+
+ my $dropdown = popup_menu {
+ name => $name,
+ class => 'dropdown',
+ values => [@values],
+ default => $default,
+ };
+
+ return $dropdown;
+} # _makeRunlogSelection
+
+sub makeAlertDropdown (;$$) {
+ my ($label, $default) = @_;
+
+ $label ||= '';
+
+ my @values;
+
+ push @values, $$_{name}
+ foreach ($clearadm->FindAlert);
+
+ my $dropdown = "$label ";
+ $dropdown .= popup_menu {
+ name => 'alert',
+ class => 'dropdown',
+ values => [sort @values],
+ default => $default,
+ };
+
+ return $dropdown;
+} # makeAlertDropdown
+
+sub makeMultiplierDropdown (;$$) {
+ my ($label, $default) = @_;
+
+ $label ||= '';
+
+ my $dropdown = "$label ";
+ $dropdown .= popup_menu {
+ name => 'multiplier',
+ class => 'dropdown',
+ values => [sort @PREDEFINED_MULTIPLIERS],
+ default => $default,
+ };
+
+ return $dropdown;
+} # makeMultiplierDropdown
+
+sub makeNoMoreThanDropdown (;$$) {
+ my ($label, $default) = @_;
+
+ $label ||= '';
+
+ my $dropdown = "$label ";
+ $dropdown .= popup_menu {
+ name => 'nomorethan',
+ class => 'dropdown',
+ values => [sort @PREDEFINED_NOTMORETHAN],
+ default => $default,
+ };
+
+ return $dropdown;
+} # makeNoMorThanDropdown
+
+sub makeFilesystemDropdown ($;$$$) {
+ my ($system, $label, $default, $onchange) = @_;
+
+ $label ||= '';
+
+ my %filesystems;
+
+ foreach ($clearadm->FindFilesystem ($system)) {
+ my %filesystem = %{$_};
+
+ my $value = "$filesystem{filesystem} ($filesystem{mount})";
+
+ $filesystems{$filesystem{filesystem}} = $value;
+ } # foreach
+
+ my $dropdown .= "$label ";
+ $dropdown .= popup_menu {
+ name => 'filesystem',
+ class => 'dropdown',
+ values => [sort keys %filesystems],
+ labels => \%filesystems,
+ onChange => ($onchange) ? $onchange : '',
+ default => $default,
+ };
+
+ return span {id => 'filesystems'}, $dropdown;
+} # makeFilesystemDropdown
+
+sub makeIntervalDropdown (;$$$) {
+ my ($label, $default, $onchange) = @_;
+
+ $label ||= '';
+
+ my @intervals = (
+ 'Minute',
+ 'Hour',
+ 'Day',
+ 'Month',
+ );
+
+ $default = ucfirst lc $default
+ if $default;
+
+ my $dropdown = "$label ";
+ $dropdown .= popup_menu {
+ name => 'scaling',
+ id => 'scalingFactor',
+ class => 'dropdown',
+ values => [@intervals],
+ default => $default,
+ onchange => $onchange,
+ };
+
+ return span {id => 'scaling'}, $dropdown;
+} # makeIntervalDropdown;
+
+sub makeNotificationDropdown (;$$) {
+ my ($label, $default) = @_;
+
+ $label ||= '';
+
+ my @values;
+
+ push @values, $$_{name}
+ foreach ($clearadm->FindNotification);
+
+ my $dropdown = "$label ";
+ $dropdown .= popup_menu {
+ name => 'notification',
+ class => 'dropdown',
+ values => [sort @values],
+ default => $default,
+ };
+
+ return $dropdown;
+} # makeNotificationDropdown
+
+sub makeRestartableDropdown (;$$) {
+ my ($label, $default) = @_;
+
+ $label ||= '';
+
+ my @values = (
+ 'true',
+ 'false',
+ );
+
+ my $dropdown = "$label ";
+ $dropdown .= popup_menu {
+ name => 'restartable',
+ class => 'dropdown',
+ values => [@values],
+ default => $default,
+ };
+
+ return $dropdown;
+} # makeRestartableDropdown
+
+sub makeSystemDropdown (;$$$%) {
+ my ($label, $default, $onchange, %systems) = @_;
+
+ $label ||= '';
+
+ foreach ($clearadm->FindSystem) {
+ my %system = %{$_};
+
+ my $value = $system{name};
+ $value .= $system{alias} ? " ($system{alias})" : '';
+
+ $systems{$system{name}} = $value;
+ } # foreach
+
+ my $systemDropdown .= "$label ";
+ $systemDropdown .= popup_menu {
+ name => 'system',
+ class => 'dropdown',
+ values => [sort keys %systems],
+ labels => \%systems,
+ onchange => ($onchange) ? $onchange : '',
+ default => $default,
+ };
+
+ return span {id => 'systems'}, $systemDropdown;
+} # makeSystemDropdown
+
+sub makeTaskDropdown (;$$) {
+ my ($label, $default) = @_;
+
+ $label ||= '';
+
+ my @values;
+
+ push @values, $$_{name}
+ foreach ($clearadm->FindTask);
+
+ my $taskDropdown = "$label ";
+ $taskDropdown .= popup_menu {
+ name => 'task',
+ class => 'dropdown',
+ values => [sort @values],
+ default => $default,
+ };
+
+ return $taskDropdown;
+} # makeTaskDropdown
+
+sub makeTimeDropdown ($$$;$$$$$) {
+ my (
+ $table,
+ $elementID,
+ $system,
+ $filesystem,
+ $label,
+ $default,
+ $interval,
+ $name,
+ ) = @_;
+
+ $label ||= '';
+
+ my @times;
+
+ $name ||= lc $label;
+
+ push @times, 'Earliest';
+
+ if ($table =~ /loadavg/i) {
+ push @times, $$_{timestamp}
+ foreach ($clearadm->GetLoadavg ($system, undef, undef, undef, $interval));
+ } elsif ($table =~ /filesystem/i) {
+ push @times, $$_{timestamp}
+ foreach ($clearadm->GetFS ($system, $filesystem, undef, undef, undef, $interval));
+ } # if
+
+ push @times, 'Latest';
+
+ unless ($default) {
+ $default = $name eq 'start' ? 'Earliest' : 'Latest';
+ } # unless
+
+ my $timeDropdown = "$label ";
+ $timeDropdown .= span {id => $elementID}, popup_menu {
+ name => $name,
+ class => 'dropdown',
+ values => [@times],
+ default => $default,
+ };
+
+ return $timeDropdown;
+} # makeTimeDropdown
+
+sub heading (;$$) {
+ my ($title, $type) = @_;
+
+ if ($title) {
+ $title = "$APPNAME: $title";
+ } else {
+ $title = $APPNAME;
+ } # if
+
+ display header;
+ display start_html {
+ -title => $title,
+ -author => 'Andrew DeFaria <Andrew@ClearSCM.com>',
+ -meta => {
+ keywords => 'ClearSCM Clearadm',
+ copyright => 'Copyright (c) ClearSCM, Inc. 2010, All rights reserved',
+ },
+ -script => [{
+ -language => 'JavaScript',
+ -src => 'clearadm.js',
+ }],
+ -style => ['clearadm.css', 'clearmenu.css'],
+ }, $title;
+
+ return if $type;
+
+ my $ieTableWrapStart = '<!--[if gt IE 6]><!--></a><!--<![endif]--><!--'
+ . '[if lt IE 7]><table border="0" cellpadding="0" '
+ . 'cellspacing="0"><tr><td><![endif]-->';
+ my $ieTableWrapEnd = '<!--[if lte IE 6]></td></tr></table></a><![endif]-->';
+
+ # Menubar
+ display div {id=>'mastheadlogo'}, h1 {class => 'title'}, $APPNAME;
+ display start_div {class => 'menu'};
+
+ # Home
+ display ul li a {href => '/clearadm'}, 'Home';
+
+ my @allSystems = $clearadm->FindSystem;
+
+ # Systems
+ display start_ul;
+ display start_li;
+ display a {href => 'systems.cgi'}, "Systems$ieTableWrapStart";
+ display start_ul;
+ foreach (@allSystems) {
+ my %system = %{$_};
+ my $sysName = ucfirst $system{name};
+ $sysName .= " ($system{alias})"
+ if $system{alias};
+
+ display li a {
+ href => "systemdetails.cgi?system=$system{name}"
+ }, ucfirst " $sysName";
+ } # foreach
+ display end_ul;
+ display $ieTableWrapEnd;
+ display end_li;
+ display end_li;
+ display end_ul;
+
+ # Filesystems
+ display start_ul;
+ display start_li;
+ display a {href => 'filesystems.cgi'}, "Filesystems$ieTableWrapStart";
+ display start_ul;
+ foreach (@allSystems) {
+ my %system = %{$_};
+ my $sysName = ucfirst $system{name};
+ $sysName .= " ($system{alias})"
+ if $system{alias};
+
+ display li a {
+ href => "filesystems.cgi?system=$system{name}"
+ }, ucfirst " $sysName";
+ } # foreach
+ display end_ul;
+ display $ieTableWrapEnd;
+ display end_li;
+ display end_ul;
+
+ # Servers
+ display start_ul;
+ display start_li;
+ display a {href => '#'}, "Servers$ieTableWrapStart";
+ display start_ul {class => 'skinny'};
+ display start_li;
+ display start_a {href => 'vobs.cgi'};
+ display "<span class='drop'><span>VOB</span>»</span>$ieTableWrapStart";
+ display start_ul;
+ display li a {href => "systemdetails.cgi?system=jupiter"}, ' Jupiter (defaria.com)';
+ display end_ul;
+ display $ieTableWrapEnd;
+ display end_li;
+
+ display start_li;
+ display start_a {href => 'views.cgi'};
+ display "<span class='drop'><span>View</span>»</span>$ieTableWrapStart";
+ display start_ul;
+ display li a {href => "systemdetails.cgi?system=earth"}, ' Earth';
+ display li a {href => "systemdetails.cgi?system=mars"}, ' Mars';
+ display end_ul;
+ display $ieTableWrapEnd;
+ display end_ul;
+ display $ieTableWrapEnd;
+ display end_li;
+ display end_ul;
+
+ # Vobs
+ display start_ul;
+ display start_li;
+ display a {href => 'vobs.cgi'}, "VOBs$ieTableWrapStart";
+ display start_ul;
+ display li a {href => '#'}, ' /vobs/clearscm';
+ display li a {href => '#'}, ' /vobs/clearadm';
+ display li a {href => '#'}, ' /vobs/test';
+ display li a {href => '#'}, ' /vobs/test2';
+ display end_ul;
+ display $ieTableWrapEnd;
+ display end_li;
+ display end_ul;
+
+ # Views
+ display start_ul;
+ display start_li;
+ display a {href => 'views.cgi'}, "Views$ieTableWrapStart";
+ display start_ul;
+ display li a {href => 'viewager.cgi'}, ' View Ager';
+ display li a {href => '#'}, ' Releast View';
+ display end_ul;
+ display $ieTableWrapEnd;
+ display end_li;
+ display end_ul;
+
+ # Configure
+ display start_ul;
+ display start_li;
+ display a {href => '#'}, "Configure$ieTableWrapStart";
+ display start_ul;
+ display li a {href => 'alerts.cgi'}, ' Alerts';
+ display li a {href => 'notifications.cgi'}, ' Notifications';
+ display li a {href => 'schedule.cgi'}, ' Schedule';
+ display li a {href => 'tasks.cgi'}, ' Tasks';
+ display end_ul;
+ display $ieTableWrapEnd;
+ display end_li;
+ display end_ul;
+
+ # Logs
+ display start_ul;
+ display start_li;
+ display a {href => '#'}, "Logs$ieTableWrapStart";
+ display start_ul;
+ display li a {href => 'alertlog.cgi'}, ' Alert';
+ display li a {href => 'runlog.cgi'}, ' Run';
+ display end_ul;
+ display $ieTableWrapEnd;
+ display end_li;
+ display end_ul;
+
+ # Help
+ display start_ul;
+ display start_li;
+ display a {href => '#'}, "Help$ieTableWrapStart";
+ display start_ul {class => 'rightmenu'};
+ display li a {href => 'readme.cgi'}, " About: $APPNAME $VERSION";
+ display end_ul;
+ display $ieTableWrapEnd;
+ display end_li;
+ display end_ul;
+ display end_div;
+
+ display start_div {class => 'page'};
+
+ return;
+} # heading
+
+sub displayAlert (;$) {
+ my ($alert) = @_;
+
+ display start_table {cellspacing => 1};
+
+ display start_Tr;
+ display th {class => 'labelCentered'}, 'Actions';
+ display th {class => 'labelCentered'}, 'Name';
+ display th {class => 'labelCentered'}, 'Type';
+ display th {class => 'labelCentered'}, 'Who';
+ display th {class => 'labelCentered'}, 'Category';
+ display end_Tr;
+
+ foreach ($clearadm->FindAlert ($alert)) {
+ my %alert = %{$_};
+
+ $alert{who} = setField $alert{who}, 'System Administrator';
+
+ display start_Tr;
+ my $areYouSure = "Are you sure you want to delete the $alert{name} alert?";
+
+ my $actions = start_form {
+ method => 'post',
+ action => 'processalert.cgi',
+ };
+
+ $actions .= input {
+ name => 'name',
+ type => 'hidden',
+ value => $alert{name},
+ };
+
+ if (InArray $alert{name}, @PREDEFINED_ALERTS) {
+ $actions .= input {
+ name => 'delete',
+ disabled => 'true',
+ type => 'image',
+ src => 'delete.png',
+ alt => 'Delete',
+ value => 'Delete',
+ title => 'Cannot delete predefined alert',
+ };
+ $actions .= input {
+ name => 'edit',
+ disabled => 'true',
+ type => 'image',
+ src => 'edit.png',
+ alt => 'Edit',
+ value => 'Edit',
+ title => 'Cannot edit predefined alert',
+ };
+ } else {
+ $actions .= input {
+ name => 'delete',
+ type => 'image',
+ src => 'delete.png',
+ alt => 'Delete',
+ value => 'Delete',
+ title => 'Delete',
+ onclick => "return AreYouSure ('$areYouSure');",
+ };
+ $actions .= input {
+ name => 'edit',
+ type => 'image',
+ src => 'edit.png',
+ alt => 'Edit',
+ value => 'Edit',
+ title => 'Edit',
+ };
+ } # if
+
+ display end_form;
+
+ my $who = $alert{who};
+
+ if ($who =~ /^([a-zA-Z0-9._-]+)@([a-zA-Z0-9.-]+\.[a-zA-Z]{2,4})$/) {
+ $who = a {href => "mailto:$1\@$2"}, $who;
+ } # if
+
+ display td {class => 'dataCentered'}, $actions;
+ display td {class => 'data'}, $alert{name};
+ display td {class => 'data'}, $alert{type};
+ display td {class => 'data'}, $who;
+ display td {class => 'data'},
+ (InArray $alert{name}, @PREDEFINED_ALERTS) ? 'Predefined' : 'User Defined';
+ display end_Tr;
+ } # foreach
+
+ display end_table;
+
+ display p {class => 'center'}, a {
+ href => 'processalert.cgi?action=Add',
+ }, 'New alert ', img {
+ src => 'add.png',
+ border => 0,
+ };
+
+ return;
+} # DisplayAlerts
+
+sub displayAlertlog (%) {
+ my (%opts) = @_;
+
+ my $optsChanged;
+
+ unless (($opts{oldalert} and $opts{alert} and
+ $opts{oldalert} eq $opts{alert}) and
+ ($opts{oldsystem} and $opts{system} and
+ $opts{oldsystem} eq $opts{system}) and
+ ($opts{oldnotification} and $opts{notification} and
+ $opts{oldnotification} eq $opts{notification})) {
+ $optsChanged = 1;
+ } # unless
+
+ my $condition;
+
+ unless ($opts{id}) {
+ $condition = "alert like '%";
+ $condition .= $opts{alert} ? $opts{alert} : '';
+ $condition .= "%'";
+ $condition .= ' and ';
+ $condition .= "system like '%";
+ $condition .= $opts{system} ? $opts{system} : '';
+ $condition .= "%'";
+ $condition .= ' and ';
+ $condition .= "notification like '%";
+ $condition .= $opts{notification} ? $opts{notification} : '';
+ $condition .= "%'";
+ } # unless
+
+ my $total = $clearadm->Count ('alertlog', $condition);
+
+ if ($opts{'nextArrow.x'}) {
+ $opts{start} = $opts{next};
+ } elsif ($opts{'prevArrow.x'}) {
+ $opts{start} = $opts{prev};
+ } else {
+ $opts{start} = 0;
+ } # if
+
+ my $next = $opts{start} + $opts{page} < $total
+ ? $opts{start} + $opts{page}
+ : $opts{start};
+ my $prev = $opts{start} - $opts{page} >= 0
+ ? $opts{start} - $opts{page}
+ : $opts{start};
+
+ my $opts = $opts{start} + 1;
+ $opts .= '-';
+ $opts .= $opts{start} + $opts{page} < $total
+ ? $opts{start} + $opts{page}
+ : $total;
+ $opts .= " of $total";
+
+ display start_form {
+ method => 'post',
+ action => 'alertlog.cgi'
+ };
+
+ # Hidden fields to pass along
+ display input {name => 'prev', type => 'hidden', value => $prev};
+ display input {name => 'next', type => 'hidden', value => $next};
+
+ display input {
+ name => 'oldalert',
+ type => 'hidden',
+ value => $opts{alert},
+ };
+ display input {
+ name => 'oldsystem',
+ type => 'hidden',
+ value => $opts{system},
+ };
+ display input {
+ name => 'oldnotification',
+ type => 'hidden',
+ value => $opts{notification},
+ };
+
+ my $caption = start_table {
+ class => 'caption',
+ cellspacing => 1,
+ width => '100%',
+ };
+
+ $caption .= start_Tr;
+
+ unless ($opts{id}) {
+ $caption .= td {align => 'left'}, input {
+ name => 'prevArrow',
+ type => 'image',
+ src => 'left.png',
+ alt => 'Previous',
+ value => 'prev',
+ };
+ } else {
+ $caption .= td {align => 'left'}, img {
+ src => 'left.png',
+ disabled => 'disabled',
+ };
+ } # unless
+
+ $caption .= td {align => 'center'}, $opts;
+
+ unless ($opts{id}) {
+ $caption .= td {align => 'right'}, input {
+ name => 'nextArrow',
+ type => 'image',
+ src => 'right.png',
+ alt => 'Next',
+ value => 'next',
+ };
+ } else {
+ $caption .= td {align => 'right'}, img {
+ src => 'right.png',
+ disabled => 'disabled',
+ };
+ } # unless
+
+ $caption .= end_Tr;
+
+ $caption .= end_table;
+
+ display start_table {cellspacing => 1, width => '98%'};
+
+ display caption $caption;
+
+ display start_Tr;
+ display th {class => 'labelCentered'}, '#';
+ display th {class => 'labelCentered'}, 'Delete';
+ display th {class => 'labelCentered'}, 'Name';
+ display th {class => 'labelCentered'}, 'System';
+ display th {class => 'labelCentered'}, 'Notification';
+ display th {class => 'labelCentered'}, 'Date/Time';
+ display th {class => 'labelCentered'}, 'Runlog';
+ display th {class => 'labelCentered'}, 'Message';
+ display end_Tr;
+
+ display start_Tr;
+ display td {
+ class => 'filter',
+ align => 'right',
+ colspan => 2,
+ }, b 'Filter:';
+ display td {
+ class => 'filter'
+ }, _makeAlertlogSelection ('alert', $opts{alert});
+ display td {
+ class => 'filter'
+ }, _makeAlertlogSelection ('system', $opts{system});
+ display td {
+ class => 'filter'
+ }, _makeAlertlogSelection ('notification', $opts{notification});
+ display td {
+ class => 'filter',
+ }, input {
+ type => 'submit',
+ value => 'Update',
+ };
+ display end_form;
+ display td {
+ class => 'filter',
+ align => 'center',
+ colspan => 2,
+ # TODO: Would like to have Clear All Alerts be Clear Alerts and for it to
+ # clear only the alerts that have been filtered.
+ }, a {
+ href => 'deletealertlog.cgi?alertlogid=all'
+ }, input {
+ type => 'button',
+ value => 'Clear All Events',
+ onclick => "return AreYouSure('Are you sure you want to delete all alerts?');",
+ };
+ display end_Tr;
+
+ my $i = $opts{start};
+
+ foreach ($clearadm->FindAlertlog (
+ $opts{alert},
+ $opts{system},
+ $opts{notification},
+ $opts{start},
+ $opts{page},
+ )) {
+ my %alertlog = setFields 'N/A', %{$_};
+
+ display start_Tr;
+ my %system = $clearadm->GetSystem ($alertlog{system});
+
+ display td {class => 'dataCentered'}, ++$i;
+ display td {class => 'dataCentered'}, a {
+ href => "deletealertlog.cgi?alertlogid=$alertlog{id}"
+ }, img {
+ src => 'delete.png',
+ alt => 'Delete',
+ title => 'Delete',
+ border => 0,
+ onclick => "return AreYouSure ('Are you sure you wish to delete this alertlog entry?');",
+ };
+ display td {class => 'data'}, a {
+ href => "alerts.cgi?alert=$alertlog{alert}"
+ }, $alertlog{alert};
+ display td {class => 'data'}, a {
+ href => "systemdetails.cgi?system=$alertlog{system}"
+ }, $alertlog{system};
+ display td {class => 'data'}, a {
+ href => "notifications.cgi?notification=$alertlog{notification}"
+ }, $alertlog{notification};
+ display td {class => 'data'}, $alertlog{timestamp};
+ display td {class => 'dataCentered'}, a {
+ href => "runlog.cgi?id=$alertlog{runlog}"
+ }, $alertlog{runlog};
+ display td {class => 'data'}, $alertlog{message};
+ display end_Tr;
+ } # foreach
+
+ display end_form;
+
+ display end_table;
+
+ return;
+} # displayAlertlog
+
+sub displayFilesystem ($) {
+ my ($systemName) = @_;
+
+ display start_table {cellspacing => 1, width => '98%'};
+
+ display start_Tr;
+ display th {class => 'labelCentered'}, 'Action';
+ display th {class => 'labelCentered'}, 'Name';
+ display th {class => 'labelCentered'}, 'Alias';
+ display th {class => 'labelCentered'}, 'Admin';
+ display th {class => 'labelCentered'}, 'Filesystem';
+ display th {class => 'labelCentered'}, 'Mount';
+ display th {class => 'labelCentered'}, 'Type';
+ display th {class => 'labelCentered'}, 'History';
+ display th {class => 'labelCentered'}, 'Used';
+ display th {class => 'labelCentered'}, 'Threshold';
+ display th {class => 'labelCentered'}, 'Usage';
+ display end_Tr;
+
+ foreach ($clearadm->FindSystem ($systemName)) {
+ my %system = %{$_};
+
+ %system = setFields ('N/A', %system);
+
+ my $admin = ($system{email} !~ 'N/A')
+ ? a {-href => "mailto:$system{email}"}, $system{admin}
+ : $system{admin};
+
+ foreach ($clearadm->FindFilesystem ($system{name})) {
+ my %filesystem = %{$_};
+
+ my %fs = $clearadm->GetLatestFS ($system{name}, $filesystem{filesystem});
+
+ my $size = autoScale $fs{size};
+ my $used = autoScale $fs{used};
+ my $free = autoScale $fs{free};
+
+ # TODO: Note that this percentages does not agree with df output. I'm not
+ # sure why.
+ my $usedPct = $fs{size} == 0 ? 0
+ : sprintf ('%.0f',
+ (($fs{reserve} + $fs{used}) / $fs{size} * 100));
+
+ my $alias = ($system{alias} !~ 'N/A')
+ ? a {
+ href => "systemdetails.cgi?system=$system{name}"
+ }, $system{alias}
+ : $system{alias};
+
+ my $class = $usedPct < $filesystem{threshold}
+ ? 'data'
+ : 'dataAlert';
+ my $classRight = $usedPct < $filesystem{threshold}
+ ? 'dataRight'
+ : 'dataRightAlert';
+ my $classCentered = $usedPct < $filesystem{threshold}
+ ? 'dataCentered'
+ : 'dataCenteredAlert';
+ my $classRightTop = $usedPct < $filesystem{threshold}
+ ? 'dataRightTop'
+ : 'dataRightAlertTop';
+
+ display start_Tr;
+ display start_td {class => 'dataCentered'};
+
+ my $areYouSure = 'Are you sure you want to delete '
+ . "$system{name}:$filesystem{filesystem}?" . '\n'
+ . 'Doing so will remove all records related to this\n'
+ . 'filesystem and its history.';
+
+ display start_form {
+ method => 'post',
+ action => "processfilesystem.cgi",
+ };
+
+ display input {
+ type => 'hidden',
+ name => 'system',
+ value => $system{name},
+ };
+ display input {
+ type => 'hidden',
+ name => 'filesystem',
+ value => $filesystem{filesystem},
+ };
+
+ display input {
+ name => 'delete',
+ type => 'image',
+ src => 'delete.png',
+ alt => 'Delete',
+ value => 'Delete',
+ title => 'Delete',
+ onclick => "return AreYouSure ('$areYouSure');"
+ };
+ display input {
+ name => 'edit',
+ type => 'image',
+ src => 'edit.png',
+ alt => 'Edit',
+ value => 'Edit',
+ title => 'Edit',
+ };
+
+ if ($filesystem{notification}) {
+ display a {
+ href => "alertlog.cgi?system=$filesystem{system}"}, img {
+ src => 'alert.png',
+ border => 0,
+ alt => 'Alert!',
+ title => 'This filesystem has alerts',
+ };
+ } # if
+
+ display end_form;
+
+ display end_td;
+ display td {class => $class},
+ a {-href => "systemdetails.cgi?system=$system{name}"}, $system{name};
+ display td {class => $class}, $alias;
+ display td {class => $class}, $admin;
+ display td {class => $class}, $filesystem{filesystem};
+ display td {class => $class}, $filesystem{mount};
+ display td {class => $class}, $filesystem{fstype};
+ display td {class => $classCentered}, $filesystem{filesystemHist};
+ display td {class => $classRightTop}, "$used ($usedPct%)<br>",
+ font {class => 'unknown'}, "$fs{timestamp}";
+ display td {class => $classRightTop}, "$filesystem{threshold}%";
+ display td {class => $class},
+ a {href =>
+ "plot.cgi?type=filesystem&system=$system{name}"
+ . "&filesystem=$filesystem{filesystem}&scaling=Day&points=7"
+ }, img {
+ src => "plotfs.cgi?system=$system{name}"
+ . "&filesystem=$filesystem{filesystem}&tiny=1",
+ border => 0,
+ };
+ display end_Tr;
+ } # foreach
+ } # foreach
+
+ display end_table;
+
+ return;
+} # displayFilesystem
+
+sub displayNotification (;$) {
+ my ($notification) = @_;
+
+ display start_table {cellspacing => 1};
+
+ display start_Tr;
+ display th {class => 'labelCentered'}, 'Actions';
+ display th {class => 'labelCentered'}, 'Name';
+ display th {class => 'labelCentered'}, 'Alert';
+ display th {class => 'labelCentered'}, 'Condition';
+ display th {class => 'labelCentered'}, 'Not More Than';
+ display th {class => 'labelCentered'}, 'Category';
+ display end_Tr;
+
+ foreach ($clearadm->FindNotification ($notification)) {
+ my %notification= setFields 'N/A', %{$_};
+
+ display start_Tr;
+ my $areYouSure = "Are you sure you want to delete the $notification{name} "
+ . 'notification?';
+
+ my $actions = start_form {
+ method => 'post',
+ action => 'processnotification.cgi',
+ };
+
+ $actions .= input {
+ name => 'name',
+ type => 'hidden',
+ value => $notification{name},
+ };
+
+ if (InArray $notification{name}, @PREDEFINED_NOTIFICATIONS) {
+ $actions .= input {
+ name => 'delete',
+ disabled => 'true',
+ type => 'image',
+ src => 'delete.png',
+ alt => 'Delete',
+ value => 'Delete',
+ title => 'Cannot delete predefined notification',
+ };
+ $actions .= input {
+ name => 'edit',
+ disabled => 'true',
+ type => 'image',
+ src => 'edit.png',
+ alt => 'Edit',
+ value => 'Edit',
+ title => 'Cannot edit predefined notification',
+ };
+ } else {
+ $actions .= input {
+ name => 'delete',
+ type => 'image',
+ src => 'delete.png',
+ alt => 'Delete',
+ value => 'Delete',
+ title => 'Delete',
+ onclick => "return AreYouSure ('$areYouSure');",
+ };
+ $actions .= input {
+ name => 'edit',
+ type => 'image',
+ src => 'edit.png',
+ alt => 'Edit',
+ value => 'Edit',
+ title => 'Edit',
+ };
+ } # if
+
+ display end_form;
+
+ display td {class => 'dataCentered'}, $actions;
+ display td {class => 'data'}, $notification{name};
+ display td {class => 'data'}, a {
+ href => "alerts.cgi?alert=$notification{alert}"
+ }, $notification{alert};
+ display td {class => 'data'}, $notification{cond};
+ display td {class => 'data'}, $notification{nomorethan};
+ display td {class => 'data'},
+ (InArray $notification{name}, @PREDEFINED_NOTIFICATIONS)
+ ? 'Predefined'
+ : 'User Defined';
+
+ display end_Tr;
+ } # foreach
+
+ display end_table;
+
+ display p {class => 'center'}, a {
+ href => 'processnotification.cgi?action=Add',
+ }, 'New notification', img {
+ src => 'add.png',
+ border => 0,
+ };
+
+ return;
+} # displayNotification
+
+sub displayRunlog (%) {
+ my (%opts) = @_;
+
+ my $optsChanged;
+
+ unless (($opts{oldtask} and $opts{task} or
+ $opts{oldtask} eq $opts{task}) and
+ ($opts{oldsystem} and $opts{system} or
+ $opts{oldsystem} eq $opts{system}) and
+ ($opts{oldnot} and $opts{not} or
+ $opts{oldnot} eq $opts{not}) and
+ ($opts{oldstatus} and $opts{status} or
+ $opts{oldstatus} eq $opts{status})) {
+ $optsChanged = 1;
+ } # unless
+
+ my $condition;
+
+ unless ($opts{id}) {
+ $condition = "task like '%";
+ $condition .= $opts{task} ? $opts{task} : '';
+ $condition .= "%'";
+
+ if ($opts{system}) {
+ if ($opts{system} eq '<NULL>') {
+ $condition .= ' and system is null';
+ undef $opts{system}
+ } elsif ($opts{system} ne 'All') {
+ $condition .= " and system like '%$opts{system}%'";;
+ } # if
+ } # if
+
+ if (defined $opts{status}) {
+ $condition .= ' and ';
+ unless ($opts{not}) {
+ $condition .= "status=$opts{status}";
+ } else {
+ $condition .= "status<>$opts{status}";
+ } # unless
+ } # if
+ } # unless
+
+ my $total = $clearadm->Count ('runlog', $condition);
+
+ $opts{start} = $opts{'nextArrow.x'} ? $opts{next} : $opts{prev};
+ $opts{start} ||= 0;
+ $opts{start} = 0
+ if $optsChanged;
+
+ my $next = $opts{start} + $opts{page} < $total
+ ? $opts{start} + $opts{page}
+ : $opts{start};
+ my $prev = $opts{start} - $opts{page} >= 0
+ ? $opts{start} - $opts{page}
+ : $opts{start};
+
+ my $opts = $opts{'nextArrow.x'} ? $opts{next} + 1 : $opts{prev} + 1;
+ $opts .= '-';
+ $opts .= $opts{start} + $opts{page} < $total
+ ? $opts{start} + $opts{page}
+ : $total;
+ $opts .= " of $total";
+
+ display start_form {
+ method => 'post',
+ action => 'runlog.cgi'
+ };
+
+ # Hidden fields to pass along
+ display input {name => 'prev', type => 'hidden', value => $prev};
+ display input {name => 'next', type => 'hidden', value => $next};
+ display input {name => 'oldtask', type => 'hidden', value => $opts{task}};
+ display input {name => 'oldsystem', type => 'hidden', value => $opts{system}};
+ display input {name => 'oldnot', type => 'hidden', value => $opts{not}};
+ display input {name => 'oldstatus', type => 'hidden', value => $opts{status}};
+
+ my $caption = start_table {
+ class => 'caption',
+ cellspacing => 1,
+ width => '100%',
+ };
+
+ $caption .= start_Tr;
+
+ unless ($opts{id}) {
+ $caption .= td {align => 'left'}, input {
+ name => 'prevArrow',
+ type => 'image',
+ src => 'left.png',
+ alt => 'Previous',
+ value => 'prev',
+ };
+ } else {
+ $caption .= td {align => 'left'}, img {
+ src => 'left.png',
+ disabled => 'disabled',
+ };
+ } # unless
+
+ $caption .= td {align => 'center'}, $opts;
+
+ unless ($opts{id}) {
+ $caption .= td {align => 'right'}, input {
+ name => 'nextArrow',
+ type => 'image',
+ src => 'right.png',
+ alt => 'Next',
+ value => 'next',
+ };
+ } else {
+ $caption .= td {align => 'right'}, img {
+ src => 'right.png',
+ disabled => 'disabled',
+ };
+ } # unless
+
+ $caption .= end_Tr;
+
+ $caption .= end_table;
+
+ display start_table {cellspacing => 1, width => '98%'};
+
+ display caption $caption;
+
+ display start_Tr;
+ display th {class => 'labelCentered'}, '#';
+ display th {class => 'labelCentered'}, 'ID';
+ display th {class => 'labelCentered'}, 'Task';
+ display th {class => 'labelCentered'}, 'System';
+ display th {class => 'labelCentered'}, 'Started';
+ display th {class => 'labelCentered'}, 'Ended';
+ display th {class => 'labelCentered'}, 'Status';
+ display th {class => 'labelCentered'}, 'Message';
+ display end_Tr;
+
+ display start_Tr;
+ $opts{not} ||= 'false';
+
+ display start_form {
+ method => 'post',
+ action => 'runlog.cgi'
+ };
+ display td {
+ class => 'filter',
+ align => 'right',
+ colspan => 2,
+ }, b 'Filter:';
+ display td {
+ class => 'filter'
+ }, _makeRunlogSelection ('task', $opts{task});
+ display td {
+ class => 'filter'
+ }, _makeRunlogSelection ('system', $opts{system});
+ display td {class => 'filter'}, ' ';
+ display td {
+ class => 'filter',
+ align => 'right',
+ }, "Not: ", checkbox {
+ name => 'not',
+ value => 'true',
+ checked => $opts{not} eq 'true' ? 1 : 0,
+ label => '',
+ };
+ display td {
+ class => 'filter'
+ }, _makeRunlogSelectionNumeric ('status', $opts{status});
+ display td {
+ class => 'filter',
+ }, input {
+ type => 'submit',
+ value => 'Update',
+ };
+
+ display end_form;
+ display end_Tr;
+
+ my $i = $opts{start};
+
+ my $status;
+
+ if (defined $opts{status}) {
+ if ($opts{status} !~ /all/i) {
+ $status = $opts{not} ne 'true' ? $opts{status} : "!$opts{status}";
+ } # if
+ } # if
+
+ foreach ($clearadm->FindRunlog (
+ $opts{task},
+ $opts{system},
+ $status,
+ $opts{id},
+ $opts{start},
+ $opts{page},
+ )) {
+ my %runlog = setFields 'N/A', %{$_};
+
+ my $class = $runlog{status} == 0
+ ? 'data'
+ : 'dataAlert';
+ my $classCentered = $runlog{status} == 0
+ ? 'dataCentered'
+ : 'dataAlertCentered';
+ my $classRight = $runlog{status} == 0
+ ? 'dataRight'
+ : 'dataAlertRight';
+
+ display start_Tr;
+ display td {class => 'dataCentered'}, ++$i;
+ display td {class => 'dataCentered'}, $runlog{id};
+ display td {class => 'data'}, a {
+ href => "tasks.cgi?task=$runlog{task}"
+ }, $runlog{task};
+ display td {class => 'data'}, $runlog{system} eq 'Localhost'
+ ? $runlog{system}
+ : a {
+ href => "systemdetails.cgi?system=$runlog{system}"
+ }, $runlog{system};
+ display td {class => 'dataCentered'}, $runlog{started};
+ display td {class => 'dataCentered'}, $runlog{ended};
+ display td {class => $classRight}, $runlog{status};
+
+ my $message = $runlog{message};
+ $message =~ s/\r\n/<br>/g;
+
+ display td {class => $class, width => '50%'}, $message;
+ display end_Tr;
+ } # foreach
+
+ display end_table;
+
+ return;
+} # displayRunlog
+
+sub displaySchedule () {
+ display start_table {cellspacing => 1};
+
+ display start_Tr;
+ display th {class => 'labelCentered'}, 'Actions';
+ display th {class => 'labelCentered'}, 'Active';
+ display th {class => 'labelCentered'}, 'Name';
+ display th {class => 'labelCentered'}, 'Task';
+ display th {class => 'labelCentered'}, 'Notification';
+ display th {class => 'labelCentered'}, 'Frequency';
+ display th {class => 'labelCentered'}, 'Category';
+ display end_Tr;
+
+ foreach ($clearadm->FindSchedule) {
+ my %schedule = setFields 'N/A', %{$_};
+
+ display start_Tr;
+ my $areYouSure = "Are you sure you want to delete the $schedule{name} "
+ . "schedule?";
+
+ my $actions = start_form {
+ method => 'post',
+ action => 'processschedule.cgi',
+ };
+
+ $actions .= input {
+ name => 'name',
+ type => 'hidden',
+ value => $schedule{name},
+ };
+
+ if (InArray $schedule{name}, @PREDEFINED_SCHEDULES) {
+ $actions .= input {
+ name => 'delete',
+ disabled => 'true',
+ type => 'image',
+ src => 'delete.png',
+ alt => 'Delete',
+ value => 'Delete',
+ title => 'Cannot delete predefined schedule',
+ };
+ $actions .= input {
+ name => 'edit',
+ disabled => 'true',
+ type => 'image',
+ src => 'edit.png',
+ alt => 'Edit',
+ value => 'Edit',
+ title => 'Cannot edit predefined schedule',
+ };
+ } else {
+ $actions .= input {
+ name => 'delete',
+ type => 'image',
+ src => 'delete.png',
+ alt => 'Delete',
+ value => 'Delete',
+ title => 'Delete',
+ onclick => "return AreYouSure ('$areYouSure');",
+ };
+ $actions .= input {
+ name => 'edit',
+ type => 'image',
+ src => 'edit.png',
+ alt => 'Edit',
+ value => 'Edit',
+ title => 'Edit',
+ };
+ } # if
+
+ display end_form;
+
+ display td {class => 'dataCentered'}, $actions;
+ display td {class => 'dataCentered'}, checkbox {
+ disabled => 'disabled',
+ checked => $schedule{active} eq 'true' ? 1 : 0,
+ };
+ display td {class => 'data'}, $schedule{name};
+ display td {class => 'data'}, a {
+ href => "tasks.cgi?task=$schedule{task}"
+ }, $schedule{task};
+ display td {class => 'data'}, a {
+ href => "notifications.cgi?notification=$schedule{notification}"
+ }, $schedule{notification};
+ display td {class => 'data'}, $schedule{frequency};
+ display td {class => 'data'},
+ (InArray $schedule{name}, @PREDEFINED_SCHEDULES)
+ ? 'Predefined'
+ : 'User Defined';
+
+ display end_Tr;
+ } # foreach
+
+ display end_table;
+
+ display p {class => 'center'}, a {
+ href => 'processschedule.cgi?action=Add',
+ }, 'New schedule', img {
+ src => 'add.png',
+ border => 0,
+ };
+
+ return;
+} # displaySchedule
+
+sub displaySystem ($) {
+ my ($systemName) = @_;
+
+ my %system = $clearadm->GetSystem ($systemName);
+
+ unless (%system) {
+ displayError "Nothing known about system $systemName";
+ return;
+ } # unless
+
+ my $lastheardfromClass = 'dataCentered';
+ my $lastheardfromData = $system{lastheardfrom};
+
+ my %load = $clearadm->GetLatestLoadavg ($systemName);
+
+ unless ($clearadm->SystemAlive (%system)) {
+ $lastheardfromClass = 'dataCenteredAlert';
+ $lastheardfromData = a {
+ href => "alertlog.cgi?system=$system{name}",
+ class => 'alert',
+ title => "Have not heard from $system{name} for a while"
+ }, $system{lastheardfrom};
+ $system{notification} = 'Heartbeat';
+ } # unless
+
+ my $admin = ($system{email})
+ ? a {-href => "mailto:$system{email}"}, $system{admin}
+ : $system{admin};
+
+ $system{alias} = setField $system{alias}, 'N/A';
+ $system{region} = setField $system{region}, 'N/A';
+
+ display start_table {cellspacing => 1};
+
+ display start_Tr;
+ my $areYouSure = 'Are you sure you want to delete this system?\n'
+ . "Doing so will remove all records related to $system{name}"
+ . '\nincluding filesystem records and history as well as '
+ . 'loadavg history.';
+
+ my $actions = start_form {
+ method => 'post',
+ action => 'processsystem.cgi',
+ };
+
+ $actions .= input {
+ name => 'name',
+ type => 'hidden',
+ value => $system{name},
+ };
+
+ $actions .= input {
+ name => 'delete',
+ type => 'image',
+ src => 'delete.png',
+ alt => 'Delete',
+ value => 'Delete',
+ title => 'Delete',
+ onclick => "return AreYouSure ('$areYouSure');",
+ };
+ $actions .= input {
+ name => 'edit',
+ type => 'image',
+ src => 'edit.png',
+ alt => 'Edit',
+ value => 'Edit',
+ title => 'Edit',
+ };
+ $actions .= checkbox {
+ disabled => 'disabled',
+ checked => $system{active} eq 'true' ? 1 : 0,
+ };
+
+ if ($system{notification}) {
+ $actions .= a {
+ href => "alertlog.cgi?system=$system{name}"}, img {
+ src => 'alert.png',
+ border => 0,
+ alt => 'Alert!',
+ title => 'This system has alerts',
+ };
+ } # if
+
+ display th {class => 'label'}, "$actions Name:";
+ display end_form;
+ display td {class => 'dataCentered', colspan => 2}, $system{name};
+ display th {class => 'label'}, 'Alias:';
+ display td {class => 'dataCentered'}, $system{alias};
+ display th {class => 'label'}, 'Admin:';
+ display td {class => 'dataCentered', colspan => 2}, $admin;
+ display th {class => 'label', colspan => 2}, 'Type:';
+ display td {class => 'dataCentered'}, $system{type};
+ display end_Tr;
+
+ display start_Tr;
+ display th {class => 'label'}, 'OS Version:';
+ display td {class => 'data', colspan => 10}, $system{os};
+ display end_Tr;
+
+ display start_Tr;
+ display th {class => 'label'}, 'Last Contacted:';
+ display td {
+ class => $lastheardfromClass,
+ colspan => 2
+ }, "$lastheardfromData ",
+ font {class => 'dim' }, "<br>Up: $load{uptime}";
+ display th {class => 'label'}, 'Port:';
+ display td {class => 'dataCentered'}, $system{port};
+ display th {class => 'label'}, 'Threshold:';
+ display td {class => 'dataCentered'}, $system{loadavgThreshold};
+ display th {class => 'label'}, 'History:';
+ display td {class => 'dataCentered'}, $system{loadavgHist};
+ display th {class => 'label'}, 'Load Avg:';
+ display td {class => 'data'},
+ a {href =>
+ "plot.cgi?type=loadavg&system=$system{name}&scaling=Hour&points=24"
+ }, img {
+ src => "plotloadavg.cgi?system=$system{name}&tiny=1",
+ border => 0,
+ };
+
+ my $description = $system{description};
+ $description =~ s/\r\n/<br>/g;
+
+ display start_Tr;
+ display th {class => 'label'}, 'Description:';
+ display td {class => 'data', colSpan => 10}, $description;
+ display end_Tr;
+
+ display end_table;
+
+ display p {class => 'center'}, a {
+ href => 'processsystem.cgi?action=Add',
+ }, 'New system', img {
+ src => 'add.png',
+ border => 0,
+ };
+
+ display h1 {class => 'center'},
+ 'Filesystem Details: ' . ucfirst $system{name};
+
+ display start_table {cellspacing => 1};
+
+ display start_Tr;
+ display th {class => 'labelCentered'}, 'Action';
+ display th {class => 'labelCentered'}, 'Filesystem';
+ display th {class => 'labelCentered'}, 'Type';
+ display th {class => 'labelCentered'}, 'Mount';
+ display th {class => 'labelCentered'}, 'Size';
+ display th {class => 'labelCentered'}, 'Used';
+ display th {class => 'labelCentered'}, 'Free';
+ display th {class => 'labelCentered'}, 'Used %';
+ display th {class => 'labelCentered'}, 'Threshold';
+ display th {class => 'labelCentered'}, 'History';
+ display th {class => 'labelCentered'}, 'Usage';
+ display end_Tr;
+
+ foreach ($clearadm->FindFilesystem ($system{name})) {
+ my %filesystem = %{$_};
+
+ my %fs = $clearadm->GetLatestFS (
+ $filesystem{system},
+ $filesystem{filesystem}
+ );
+
+ my $size = autoScale $fs{size};
+ my $used = autoScale $fs{used};
+ my $free = autoScale $fs{free};
+
+ # TODO: Note that this percentages does not agree with df output. I'm not
+ # sure why.
+ my $usedPct = $fs{size} == 0 ? 0
+ : sprintf ('%.0f',
+ (($fs{reserve} + $fs{used}) / $fs{size} * 100));
+
+ my $class = $usedPct < $filesystem{threshold}
+ ? 'data'
+ : 'dataAlert';
+ my $classCentered = $class . 'Centered';
+ my $classRight = $class . 'Right';
+
+ display start_Tr;
+ display start_td {class => 'data'};
+
+ my $areYouSure = 'Are you sure you want to delete '
+ . "$system{name}:$filesystem{filesystem}?" . '\n'
+ . 'Doing so will remove all records related to this\n'
+ . 'filesystem and its history.';
+
+ display start_form {
+ method => 'post',
+ action => 'processfilesystem.cgi',
+ };
+
+ display input {
+ type => 'hidden',
+ name => 'system',
+ value => $system{name},
+ };
+ display input {
+ type => 'hidden',
+ name => 'filesystem',
+ value => $filesystem{filesystem},
+ };
+
+ display input {
+ name => 'delete',
+ type => 'image',
+ src => 'delete.png',
+ alt => 'Delete',
+ value => 'Delete',
+ title => 'Delete',
+ onclick => "return AreYouSure ('$areYouSure');"
+ };
+ display input {
+ name => 'edit',
+ type => 'image',
+ src => 'edit.png',
+ alt => 'Edit',
+ value => 'Edit',
+ title => 'Edit',
+ };
+
+ if ($filesystem{notification}) {
+ display a {
+ href => "alertlog.cgi?system=$filesystem{system}"}, img {
+ src => 'alert.png',
+ border => 0,
+ alt => 'Alert!',
+ title => 'This filesystem has alerts',
+ };
+ } # if
+
+ display end_form;
+ display td {class => $class}, $filesystem{filesystem};
+ display td {class => $classCentered}, $filesystem{fstype};
+ display td {class => $class}, $filesystem{mount};
+ display td {class => $classRight}, $size;
+ display td {class => $classRight}, $used;
+ display td {class => $classRight}, $free;
+ display td {class => $classRight}, "$usedPct%";
+ display td {class => $classRight}, "$filesystem{threshold}%";
+ display td {class => $classCentered}, $filesystem{filesystemHist};
+ display td {class => $classCentered},
+ a {href =>
+ "plot.cgi?type=filesystem&system=$system{name}"
+ . "&filesystem=$filesystem{filesystem}"
+ . "&scaling=Day&points=7"
+ }, img {
+ src => "plotfs.cgi?system=$system{name}&"
+ . "filesystem=$filesystem{filesystem}"
+ . '&tiny=1',
+ border => 0,
+ };
+ display end_Tr;
+ } # foreach
+
+ display end_table;
+
+ return;
+} # displaySystem
+
+sub displayTask (;$) {
+ my ($task) = @_;
+
+ display start_table {cellspacing => 1, width => '98%'};
+
+ display start_Tr;
+ display th {class => 'labelCentered'}, 'Actions';
+ display th {class => 'labelCentered'}, 'Name';
+ display th {class => 'labelCentered'}, 'System';
+ display th {class => 'labelCentered'}, 'Description';
+ display th {class => 'labelCentered'}, 'Command';
+ display th {class => 'labelCentered'}, 'Restartable';
+ display th {class => 'labelCentered'}, 'Category';
+ display end_Tr;
+
+ foreach ($clearadm->FindTask ($task)) {
+ my %task = %{$_};
+
+ $task{system} = 'All Systems'
+ unless $task{system};
+
+ display start_Tr;
+ my $areYouSure = "Are you sure you want to delete the $task{name} task?";
+
+ my $actions = start_form {
+ method => 'post',
+ action => 'processtask.cgi',
+ };
+
+ $actions .= input {
+ name => 'name',
+ type => 'hidden',
+ value => $task{name},
+ };
+
+ if (InArray $task{name}, @PREDEFINED_TASKS) {
+ $actions .= input {
+ name => 'delete',
+ disabled => 'true',
+ type => 'image',
+ src => 'delete.png',
+ alt => 'Delete',
+ value => 'Delete',
+ title => 'Cannot delete predefined task',
+ };
+ $actions .= input {
+ name => 'edit',
+ disabled => 'true',
+ type => 'image',
+ src => 'edit.png',
+ alt => 'Edit',
+ value => 'Edit',
+ title => 'Cannot edit predefined task',
+ };
+ } else {
+ $actions .= input {
+ name => 'delete',
+ type => 'image',
+ src => 'delete.png',
+ alt => 'Delete',
+ value => 'Delete',
+ title => 'Delete',
+ onclick => "return AreYouSure ('$areYouSure');",
+ };
+ $actions .= input {
+ name => 'edit',
+ type => 'image',
+ src => 'edit.png',
+ alt => 'Edit',
+ value => 'Edit',
+ title => 'Edit',
+ };
+ } # if
+
+ display end_form;
+
+ display td {class => 'dataCentered'}, $actions;
+ display td {class => 'data'}, $task{name};
+ display td {class => 'data'}, $task{system};
+ display td {class => 'data'}, $task{description};
+ display td {class => 'data'}, $task{command};
+ display td {class => 'dataCentered'}, $task{restartable};
+ display td {class => 'data'},
+ (InArray $task{name}, @PREDEFINED_TASKS) ? 'Predefined' : 'User Defined';
+ display end_Tr;
+ } # foreach
+
+ display end_table;
+
+ display p {class => 'center'}, a {
+ href => 'processtask.cgi?action=Add',
+ }, 'New task', img {
+ src => 'add.png',
+ border => 0,
+ };
+
+ return;
+} # DisplayAlerts
+
+sub editAlert (;$) {
+ my ($alert) = @_;
+
+ display start_form (
+ -method => 'post',
+ -action => 'processalert.cgi',
+ -onsubmit => 'return validateAlert (this);',
+ );
+
+ my %alert;
+
+ if ($alert) {
+ %alert = $clearadm->GetAlert ($alert);
+
+ return
+ unless %alert;
+
+ display input {
+ name => 'oldname',
+ type => 'hidden',
+ value => $alert,
+ };
+ } else {
+ $alert= '';
+ } # if
+
+ display input {
+ name => 'action',
+ type => 'hidden',
+ value => 'Post',
+ };
+
+ display start_table {cellspacing => 1};
+
+ display start_Tr;
+ display th {class => 'labelCentered'}, 'Name';
+ display th {class => 'labelCentered'}, 'Type';
+ display th {class => 'labelCentered'}, 'Who';
+ display end_Tr;
+
+ display start_Tr;
+ display td {
+ class => 'data',
+ }, input {
+ class => 'inputfield',
+ maxlength => 255,
+ name => 'name',
+ size => 20,
+ type => 'text',
+ value => $alert ? $alert{name} : '',
+ };
+ display td {
+ class => 'dataCentered',
+ }, popup_menu {
+ name => 'type',
+ class => 'dropdown',
+ values => [ 'email', 'page', 'im' ],
+ default => $alert ? $alert{type} : 'email',
+ };
+ display td {
+ class => 'data',
+ }, input {
+ class => 'inputfield',
+ maxlength => 255,
+ name => 'who',
+ size => 20,
+ type => 'text',
+ value => $alert ? $alert{who} : '',
+ };
+ display end_Tr;
+ display end_table;
+
+ display '<center>';
+ display p submit ({value => $alert ? 'Update' : 'Add'}), reset;
+ display '</center>';
+
+ display end_form;
+
+ return;
+} # editAlert
+
+sub editFilesystem ($$) {
+ my ($system, $filesystem) = @_;
+
+ display start_form (
+ -method => 'post',
+ -action => 'processfilesystem.cgi',
+ );
+
+ display start_table {width => '800px', cellspacing => 1};
+
+ display start_Tr;
+ display th {class => 'labelCentered'}, 'Filesystem';
+ display th {class => 'labelCentered'}, 'Type';
+ display th {class => 'labelCentered'}, 'Mount';
+ display th {class => 'labelCentered'}, 'Size';
+ display th {class => 'labelCentered'}, 'Used';
+ display th {class => 'labelCentered'}, 'Free';
+ display th {class => 'labelCentered'}, 'Used %';
+ display th {class => 'labelCentered'}, 'History';
+ display th {class => 'labelCentered'}, 'Threshold';
+ display end_Tr;
+
+ my %filesystem = $clearadm->GetFilesystem ($system, $filesystem);
+ my %fs = $clearadm->GetLatestFS ($system, $filesystem);
+
+ display input {
+ name => 'action',
+ type => 'hidden',
+ value => 'Post',
+ };
+ display input {
+ name => 'system',
+ type => 'hidden',
+ value => $filesystem{system},
+ };
+ display input {
+ name => 'filesystem',
+ type => 'hidden',
+ value => $filesystem{filesystem},
+ } ;
+
+ my $size = autoScale $fs{size};
+ my $used = autoScale $fs{used};
+ my $free = autoScale $fs{free};
+
+ display start_Tr;
+ display td {class => 'data'}, $filesystem{filesystem};
+ display td {class => 'dataCentered'}, $filesystem{fstype};
+ display td {class => 'data'}, $filesystem{mount};
+ display td {class => 'dataRight'}, $size;
+ display td {class => 'dataRight'}, $used;
+ display td {class => 'dataRight'}, $free;
+ # TODO: Note that this percentages does not agree with df output. I'm not
+ # sure why.
+ display td {class => 'dataCentered'},
+ sprintf ('%.0f%%', (($fs{reserve} + $fs{used}) / $fs{size} * 100));
+
+ my $historyDropdown = popup_menu {
+ name => 'filesystemHist',
+ class => 'dropdown',
+ values => [
+ '1 month',
+ '2 months',
+ '3 months',
+ '4 months',
+ '5 months',
+ '6 months',
+ '7 months',
+ '8 months',
+ '9 months',
+ '10 months',
+ '11 months',
+ '1 year',
+ ],
+ default => $system ? $filesystem{filesystemHist} : '6 months',
+ };
+
+ display td {
+ class => 'dataRight',
+ }, $historyDropdown;
+
+ my $thresholdDropdown = popup_menu {
+ name => 'threshold',
+ class => 'dropdown',
+ values => [1 .. 100],
+ default => $filesystem{threshold},
+ };
+ display td {class => 'dataCentered'}, $thresholdDropdown . '%';
+ display end_Tr;
+
+ display end_table;
+
+ display '<center>';
+ display p submit ({value => 'Update'}), reset;
+ display '</center>';
+
+ display end_form;
+
+ return;
+} # editFilesytem
+
+sub editNotification (;$) {
+ my ($notification) = @_;
+
+ display start_form (
+ -method => 'post',
+ -action => 'processnotification.cgi',
+ -onsubmit => 'return validateNotification (this);',
+ );
+
+ my %notification;
+
+ if ($notification) {
+ %notification = $clearadm->GetNotification ($notification);
+
+ return
+ unless %notification;
+
+ display input {
+ name => 'oldname',
+ type => 'hidden',
+ value => $notification,
+ };
+ } else {
+ $notification = '';
+ } # if
+
+ display input {
+ name => 'action',
+ type => 'hidden',
+ value => 'Post',
+ };
+
+ display start_table {cellspacing => 1};
+
+ display start_Tr;
+ display th {class => 'labelCentered'}, 'Name';
+ display th {class => 'labelCentered'}, 'Alert';
+ display th {class => 'labelCentered'}, 'Condition';
+ display th {class => 'labelCentered'}, 'Not More Than';
+ display end_Tr;
+
+ display start_Tr;
+ display td {
+ class => 'data',
+ }, input {
+ class => 'inputfield',
+ maxlength => 255,
+ name => 'name',
+ size => 20,
+ type => 'text',
+ value => $notification ? $notification{name} : '',
+ };
+
+ display td {
+ class => 'dataCentered',
+ }, makeAlertDropdown undef, $notification{alert}
+ ? $notification{alert}
+ : 'Email admin';
+
+ display td {
+ class => 'data',
+ }, input {
+ class => 'inputfield',
+ maxlength => 255,
+ name => 'cond',
+ size => 20,
+ type => 'text',
+ value => $notification ? $notification{cond} : '',
+ };
+ display td {
+ class => 'dataCentered',
+ }, makeNoMoreThanDropdown undef, $notification{nomorethan};
+
+ display end_Tr;
+ display end_table;
+
+ display '<center>';
+ display p submit ({value => $notification ? 'Update' : 'Add'}), reset;
+ display '</center>';
+
+ display end_form;
+
+ return;
+} # editNotification
+
+sub editSchedule (;$) {
+ my ($schedule) = @_;
+
+ display start_form (
+ -method => 'post',
+ -action => 'processschedule.cgi',
+ -onsubmit => 'return validateSchedule (this);',
+ );
+
+ my %schedule;
+
+ if ($schedule) {
+ %schedule = $clearadm->GetSchedule ($schedule);
+
+ return
+ unless %schedule;
+
+ display input {
+ name => 'oldname',
+ type => 'hidden',
+ value => $schedule,
+ };
+ } else {
+ $schedule = '';
+ } # if
+
+ display input {
+ name => 'action',
+ type => 'hidden',
+ value => 'Post',
+ };
+
+ display start_table {cellspacing => 1};
+
+ display start_Tr;
+ display th {class => 'labelCentered'}, 'Active';
+ display th {class => 'labelCentered'}, 'Name';
+ display th {class => 'labelCentered'}, 'Task';
+ display th {class => 'labelCentered'}, 'Notification';
+ display th {class => 'labelCentered'}, 'Frequency';
+ display end_Tr;
+
+ display start_Tr;
+ display td {
+ class => 'dataCentered',
+ }, checkbox {
+ name => 'active',
+ value => 'true',
+ checked => $schedule{active} eq 'false' ? 0 : 1,
+ label => '',
+ };
+ display td {
+ class => 'data',
+ }, input {
+ class => 'inputfield',
+ maxlength => 255,
+ name => 'name',
+ size => 20,
+ type => 'text',
+ value => $schedule ? $schedule{name} : '',
+ };
+ display td {
+ class => 'dataCentered',
+ }, makeTaskDropdown undef, $schedule{task};
+ display td {
+ class => 'dataCentered',
+ }, makeNotificationDropdown undef, $schedule{notification};
+
+ my $nbr = 5;
+ my $multiplier = 'minutes';
+
+ if ($schedule{frequency} =~ /(\d+)\s(\S+)/ ) {
+ $nbr = $1;
+ $multiplier = $2;
+
+ $multiplier .= 's' if $nbr == 1;
+ } # if
+
+ display td {
+ class => 'data',
+ }, input {
+ class => 'inputfieldRight',
+ maxlength => 3,
+ name => 'nbr',
+ size => 1,
+ type => 'text',
+ value => $nbr,
+ },
+ ' ',
+ makeMultiplierDropdown undef, $multiplier;
+
+ display end_Tr;
+ display end_table;
+
+ display '<center>';
+ display p submit ({value => $schedule ? 'Update' : 'Add'}), reset;
+ display '</center>';
+
+ display end_form;
+
+ return;
+} # editSchedule
+
+sub editSystem (;$) {
+ my ($system) = @_;
+
+ display start_form (
+ -method => 'post',
+ -action => 'processsystem.cgi',
+ -onsubmit => 'return validateSystem (this);',
+ );
+
+ my %system;
+
+ if ($system) {
+ %system = $clearadm->GetSystem ($system);
+
+ return
+ unless %system;
+
+ display input {
+ name => 'name',
+ type => 'hidden',
+ value => $system,
+ };
+ } else {
+ $system = '';
+ } # if
+
+ display input {
+ name => 'action',
+ type => 'hidden',
+ value => 'Post',
+ };
+
+ display start_table {cellspacing => 1};
+
+ display start_Tr;
+ display th {class => 'label'}, checkbox ({
+ name => 'active',
+ value => 'true',
+ checked => $system{active} eq 'false' ? 0 : 1,
+ label => '',
+ }) . ' Name: ';
+
+ if ($system) {
+ display td {class => 'data'}, $system{name};
+ } else {
+ display td {
+ class => 'data',
+ }, input {
+ class => 'inputfield',
+ maxlength => 255,
+ name => 'name',
+ size => 20,
+ type => 'text',
+ };
+ } # if
+
+ display th {class => 'label'}, 'Alias:';
+ display td {
+ class => 'data',
+ }, input {
+ class => 'inputfield',
+ maxlength => 255,
+ name => 'alias',
+ size => 20,
+ type => 'text',
+ value => $system ? $system{alias} : '',
+ };
+
+ display th {class => 'label'}, 'Port:';
+ display td {
+ class => 'dataRight',
+ }, input {
+ class => 'inputfieldRight',
+ maxlength => 6,
+ name => 'port',
+ size => 4,
+ type => 'text',
+ value => $system
+ ? $system{port}
+ : $Clearadm::CLEAROPTS{CLEARADM_PORT},
+ };
+
+ my $systemTypeDropdown = popup_menu {
+ name => 'type',
+ class => 'dropdown',
+ values => ['Unix', 'Linux', 'Windows'],
+ default => $system ? $system{type} : 'Linux',
+ };
+
+ display th {class => 'label'}, 'Type:';
+ display td {
+ class => 'dataRight',
+ }, $systemTypeDropdown;
+ display end_Tr;
+
+ display start_Tr;
+ display th {class => 'label'}, 'Admin:';
+ display td {
+ class => 'data',
+ }, input {
+ class => 'inputfield',
+ maxlength => 255,
+ name => 'admin',
+ size => 20,
+ type => 'text',
+ value => $system ? $system{admin} : '',
+ };
+ display th {class => 'label'}, 'Admin Email:';
+ display td {
+ class => 'data',
+ }, input {
+ class => 'inputfield',
+ maxlength => 255,
+ name => 'email',
+ size => 20,
+ type => 'text',
+ value => $system ? $system{email} : '',
+ };
+
+ display th {class => 'label'}, 'Threshold:';
+ display td {
+ class => 'dataRight',
+ }, input {
+ class => 'inputfieldRight',
+ maxlength => 5,
+ name => 'loadavgThreshold',
+ size => 3,
+ type => 'text',
+ value => $system
+ ? $system{loadavgThreshold}
+ : $Clearadm::CLEAROPTS{CLEARADM_LOADAVG_THRESHOLD},
+ };
+
+ my $historyDropdown = popup_menu {
+ name => 'loadavgHist',
+ class => 'dropdown',
+ values => [
+ '1 month',
+ '2 months',
+ '3 months',
+ '4 months',
+ '5 months',
+ '6 months',
+ '7 months',
+ '8 months',
+ '9 months',
+ '10 months',
+ '11 months',
+ '1 year',
+ ],
+ default => $system ? $system{loadavgHist} : '6 months',
+ };
+
+ display th {class => 'label'}, 'History:';
+ display td {
+ class => 'dataRight',
+ }, $historyDropdown;
+
+ my $description = $system ? $system{description} : '';
+ $description =~ s/\r\n/<br>/g;
+
+ display start_Tr;
+ display th {class => 'label'}, 'Description:';
+ display td {
+ class => 'data',
+ colspan => 7,
+ }, textarea {
+ class => 'inputfield',
+ cols => 103,
+ name => 'description',
+ rows => 3,
+ value => $description,
+ };
+ display end_Tr;
+ display end_table;
+
+ display '<center>';
+ display p submit ({value => $system ? 'Update' : 'Add'}), reset;
+ display '</center>';
+
+ display end_form;
+
+ return;
+} # editSystem
+
+sub editTask (;$) {
+ my ($task) = @_;
+
+ display start_form (
+ -method => 'post',
+ -action => 'processtask.cgi',
+ -onsubmit => 'return validateTask (this);',
+ );
+
+ my %task;
+
+ if ($task) {
+ %task = $clearadm->GetTask ($task);
+
+ return
+ unless %task;
+
+ display input {
+ name => 'oldname',
+ type => 'hidden',
+ value => $task,
+ };
+ } else {
+ $task = '';
+ } # if
+
+ display input {
+ name => 'action',
+ type => 'hidden',
+ value => 'Post',
+ };
+
+ display start_table {cellspacing => 1};
+
+ display start_Tr;
+ display th {class => 'labelCentered'}, 'Name';
+ display th {class => 'labelCentered'}, 'System';
+ display th {class => 'labelCentered'}, 'Description';
+ display th {class => 'labelCentered'}, 'Command';
+ display th {class => 'labelCentered'}, 'Restartable';
+ display end_Tr;
+
+ display start_Tr;
+ display td {
+ class => 'data',
+ }, input {
+ class => 'inputfield',
+ maxlength => 255,
+ name => 'name',
+ size => 15,
+ type => 'text',
+ value => $task ? $task{name} : '',
+ };
+ my $systemDropdown = makeSystemDropdown (
+ undef,
+ $task{system} ? $task{system} : 'All Systems',
+ undef, (
+ 'All systems' => undef,
+ 'Localhost' => 'Localhost',
+ ),
+ );
+
+ display td {class => 'data'}, $systemDropdown;
+
+ display td {
+ class => 'data',
+ }, input {
+ class => 'inputfield',
+ maxlength => 255,
+ name => 'description',
+ size => 30,
+ type => 'text',
+ value => $task ? $task{description} : '',
+ };
+
+ display td {
+ class => 'data',
+ }, input {
+ class => 'inputfield',
+ maxlength => 255,
+ name => 'command',
+ size => 40,
+ type => 'text',
+ value => $task ? $task{command} : '',
+ };
+
+ display td {
+ class => 'dataCentered',
+ }, makeRestartableDropdown undef, $task{restartable};
+
+ display end_Tr;
+ display end_table;
+
+ display '<center>';
+ display p submit ({value => $task ? 'Update' : 'Add'}), reset;
+ display '</center>';
+
+ display end_form;
+
+ return;
+} # editTask
+
+sub footing () {
+ my $clearscm = a {-href => 'http://clearscm.com'}, 'ClearSCM, Inc.';
+
+ # Figure out which script by using CLEARADM_BASE.
+ my $script = basename (url {-absolute => 1});
+ $script = 'index.cgi'
+ if $script eq 'clearadm';
+
+ my $scriptFullPath = "$Clearadm::CLEAROPTS{CLEARADM_BASE}/$script";
+
+ my ($year, $mon, $mday, $hour, $min, $sec) =
+ ymdhms ((stat ($scriptFullPath))[9]);
+
+ my $dateModified = "$mon/$mday/$year @ $hour:$min";
+
+ $script = a {
+ -href => "http://clearscm.com/php/cvs_man.php?file=clearadm/$script"
+ }, $script;
+
+ display end_div;
+
+ display start_div {-class => 'copyright'};
+ display "$script: Last modified: $dateModified";
+ display br "Copyright © $year, $clearscm - All rights reserved";
+ display end_div;
+
+ print end_html;
+
+ return;
+} # footing
+
+1;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<Carp>
+
+L<CGI>
+
+L<File::Basename|File::Basename>
+
+L<FindBin>
+
+L<GD>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ Clearadm
+ DateUtils
+ Display
+ Utils
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Clearadm.pm">Clearadm</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/DateUtils.pm">DateUtils</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Utils.pm">Utils</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this module.
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2010, ClearSCM, Inc. All rights reserved.
+
+=cut
--- /dev/null
+=pod
+
+=head1 NAME $RCSfile: Clearexec.pm,v $
+
+Clearexec - Execute remote commands locally
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.18 $
+
+=item Created
+
+Tue Dec 07 09:13:27 EST 2010
+
+=item Modified
+
+$Date: 2012/12/16 18:00:16 $
+
+=back
+
+=head1 SYNOPSIS
+
+Provides an interface to the Clearexec object. Clearexec is a daemon that runs
+on a host and accepts requests to execute commands locally and send the results
+back to the caller.
+
+=head1 DESCRIPTION
+
+The results are sent back as follows:
+
+ Status: <status>
+ <command output>
+
+This allows the caller to determine if the command execution was successful as
+well as capture the commands output.
+
+=head1 ROUTINES
+
+The following methods are available:
+
+=cut
+
+package Clearexec;
+
+use strict;
+use warnings;
+
+use Carp;
+use FindBin;
+use IO::Socket;
+use Net::hostent;
+use POSIX qw(:sys_wait_h);
+use Errno;
+
+use lib "$FindBin::Bin/../../lib";
+
+use DateUtils;
+use Display;
+use GetConfig;
+use Utils;
+
+# Seed options from config file
+our %CLEAROPTS = GetConfig ("$FindBin::Bin/etc/clearexec.conf");
+
+our $VERSION = '$Revision: 1.18 $';
+($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+# Override options if in the environment
+$CLEAROPTS{CLEAREXEC_HOST} = $ENV{CLEAREXEC_HOST}
+ if $ENV{CLEAREXEC_HOST};
+$CLEAROPTS{CLEAREXEC_PORT} = $ENV{CLEAREXEC_PORT}
+ if $ENV{CLEAREXEC_PORT};
+$CLEAROPTS{CLEAREXEC_MULTITHREADED} = $ENV{CLEAREXEC_MULTITHREADED}
+ if $ENV{CLEAREXEC_MULTITHREADED};
+
+sub new () {
+ my ($class) = @_;
+
+ my $clearadm = bless {}, $class;
+
+ $clearadm->{multithreaded} = $CLEAROPTS{CLEAREXEC_MULTITHREADED};
+
+ return $clearadm;
+} # new
+
+sub _tag ($) {
+ my ($self, $msg) = @_;
+
+ my $tag = YMDHMS;
+ $tag .= ' ';
+ $tag .= $self->{pid} ? "[$self->{pid}] " : '';
+
+ return "$tag$msg";
+} # _tag
+
+sub _verbose ($) {
+ my ($self, $msg) = @_;
+
+ verbose $self->_tag ($msg);
+
+ return;
+} # _verbose
+
+sub _debug ($) {
+ my ($self, $msg) = @_;
+
+ debug $self->_tag ($msg);
+
+ return;
+} # _debug
+
+sub _log ($) {
+ my ($self, $msg) = @_;
+
+ display $self->_tag ($msg);
+
+ return;
+} # log
+
+sub _endServer () {
+ display "Clearexec V$VERSION shutdown at " . localtime;
+
+ # Kill process group
+ kill 'TERM', -$$;
+
+ # Wait for all children to die
+ while (wait != -1) {
+
+ # do nothing
+ } # while
+
+ # Now that we are alone, we can simply exit
+ exit;
+} # _endServer
+
+sub _restartServer () {
+
+ # Not sure what to do on a restart server
+ display 'Entered _restartServer';
+
+ return;
+} # _restartServer
+
+sub setMultithreaded ($) {
+ my ($self, $value) = @_;
+
+ my $oldValue = $self->{multithreaded};
+
+ $self->{multithreaded} = $value;
+
+ return $oldValue;
+} # setMultithreaded
+
+sub getMultithreaded () {
+ my ($self) = @_;
+
+ return $self->{multithreaded};
+} # getMultithreaded
+
+sub connectToServer (;$$) {
+ my ($self, $host, $port) = @_;
+
+ $host ||= $CLEAROPTS{CLEAREXEC_HOST};
+ $port ||= $CLEAROPTS{CLEAREXEC_PORT};
+
+ $self->{socket} = IO::Socket::INET->new (
+ Proto => 'tcp',
+ PeerAddr => $host,
+ PeerPort => $port,
+ );
+
+ return unless $self->{socket};
+
+ $self->{socket}->autoflush
+ if $self->{socket};
+
+ $self->{host} = $host;
+ $self->{port} = $port;
+
+ if ($self->{socket}) {
+ return 1;
+ } else {
+ return;
+ } # if
+
+ return;
+} # connectToServer
+
+sub disconnectFromServer () {
+ my ($self) = @_;
+
+ undef $self->{socket};
+
+ return;
+} # disconnectFromServer
+
+sub execute ($) {
+ my ($self, $cmd) = @_;
+
+ return (-1, 'Unable to talk to server')
+ unless $self->{socket};
+
+ my ($status, $statusLine, @output) = (-1, '', ());
+
+ my $server = $self->{socket};
+
+ print $server "$cmd\n";
+
+ my $response;
+
+ while (defined ($response = <$server>)) {
+ if ($response =~ /Clearexec Status: (-*\d+)/) {
+ $status = $1;
+ last;
+ } # if
+
+ push @output, $response;
+ } # while
+
+ chomp @output;
+
+ return ($status, @output);
+} # execute
+
+sub _serviceClient ($$) {
+ my ($self, $host, $client) = @_;
+
+ $self->_verbose ("Serving requests from $host");
+
+ # Set autoflush for client
+ $client->autoflush
+ if $client;
+
+ while () {
+ # Read command from client
+ my $cmd = <$client>;
+
+ last unless $cmd;
+
+ chomp $cmd;
+
+ next if $cmd eq '';
+
+ last if $cmd =~ /quit|exit/i;
+
+ $self->_debug ("$host wants us to do $cmd");
+
+ my ($status, @output);
+
+ $status = 0;
+
+ if ($cmd =~ /stopserver/i) {
+ if ($self->{server}) {
+ $self->_verbose ("$host requested to stop server [$self->{server}]");
+
+ # Send server hangup signal
+ kill 'HUP', $self->{server};
+ } else {
+ $self->_verbose ('Shutting down server');
+
+ print $client "Clearexec Status: 0\n";
+
+ exit;
+ } # if
+
+ $self->_debug ("Returning 0, undef");
+ } else {
+ # Combines STDERR -> STDOUT if not already specified
+ $cmd .= ' 2>&1'
+ unless $cmd =~ /2>&1/;
+
+ $self->_debug ("Executing $cmd");
+ ($status, @output) = Execute $cmd;
+ $self->_debug ("Status: $status");
+ } # if
+
+ print $client "$_\n" foreach (@output);
+ print $client "Clearexec Status: $status\n";
+
+ $self->_debug ("Looping around for next command");
+ } # while
+
+ close $client;
+
+ $self->_verbose ("Serviced requests from $host");
+
+ return;
+} # _serviceClient
+
+sub startServer (;$) {
+ my ($self, $port) = @_;
+
+ $port ||= $CLEAROPTS{CLEAREXEC_PORT};
+
+ # Create new socket to communicate to clients with
+ $self->{socket} = IO::Socket::INET->new (
+ Proto => 'tcp',
+ LocalPort => $port,
+ Listen => SOMAXCONN,
+ Reuse => 1
+ );
+
+ error "Could not create socket - $!", 1
+ unless $self->{socket};
+
+ # Announce ourselves
+ $self->_log ("Clearexec V$VERSION accepting clients at " . localtime);
+
+ # Now wait for an incoming request
+ my $client;
+
+ while () {
+ $client = $self->{socket}->accept;
+
+ if ($? == -1) {\r
+ if ($!{EINTR}) {
+ next;
+ } else {
+ error "Accept called failed (Error: $?) - $!", 1;
+ } # if\r
+ } # if
+
+ my $hostinfo = gethostbyaddr $client->peeraddr;
+ my $host = $hostinfo->name || $client->peerhost;
+
+ $self->_verbose ("$host is requesting service");
+
+ if ($self->getMultithreaded) {
+ $self->{server} = $$;
+
+ my $childpid;
+
+ $self->_debug ("Spawning child to handle request");
+
+ error "Can't fork: $!"
+ unless defined ($childpid = fork);
+
+ if ($childpid) {
+ $self->{pid} = $$;
+
+ # On Unix/Linux, setting SIGCHLD to ignore auto reaps dead children.
+ $SIG{CHLD} = "IGNORE";
+ $SIG{HUP} = \&_endServer;
+ $SIG{USR2} = \&_restartServer;
+
+ $self->_debug ("Parent produced child [$childpid]");
+ } else {
+ # In child process - ServiceClient
+ $self->{pid} = $$;
+
+ $self->_debug ("Calling _serviceClient");
+ $self->_serviceClient ($host, $client);
+ $self->_debug ("Returned from _serviceClient - exiting...");
+
+ exit;
+ } # if
+ } else {
+ $self->_serviceClient ($host, $client);
+ } # if
+ } # while
+} # startServer
+
+1;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<Carp>
+
+L<FindBin>
+
+L<IO::Socket|IO::Socket>
+
+L<Net::hostent|Net::hostent>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ DateUtils
+ Display
+ GetConfig
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/DateUtils.pm">Display</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/GetConfig.pm">GetConf</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this module.
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2010, ClearSCM, Inc. All rights reserved.
+
+=cut
--- /dev/null
+=pod
+
+=head2 NAME $RCSfile: User.pm,v $
+
+Return information about a user
+
+=head2 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.4 $
+
+=item Created
+
+Tue Jan 3 11:36:10 PST 2006
+
+=item Modified
+
+$Date: 2011/01/09 01:03:10 $
+
+=back
+
+=head2 SYNOPSIS
+
+This module implements a User object which returns information about a user.
+
+ my $user = new User ('adefaria');
+
+ print "Fullname: $user->{fullname}\n";
+ print "EMail: $user->{email}\n";
+
+=head2 DESCRIPTION
+
+This module instanciates a user object for the given user identifier and
+then collects information about the user such as fullname, email, etc. It does
+so by contacting Active Directory in a Windows domain or other directory servers
+depending on the site. As such exactly what data members are available may
+change or be different from site to site.
+
+=cut
+
+package User;
+
+use strict;
+use warnings;
+
+use Carp;
+use Net::LDAP;
+
+use GetConfig;
+
+# Seed options from config file
+our %CLEAROPTS= GetConfig ("$FindBin::Bin/etc/clearuser.conf");
+
+our $VERSION = '$Revision: 1.4 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+# Override options if in the environment
+$CLEAROPTS{CLEARUSER_LDAPHOST} = $ENV{CLEARUSER_LDAPHOST}
+ if $ENV{CLEARUSER_LDAPHOST};
+$CLEAROPTS{CLEARUSER_BIND} = $ENV{CLEARUSER_BIND}
+ if $ENV{CLEARUSER_BIND};
+$CLEAROPTS{CLEARUSER_USERNAME} = $ENV{CLEARUSER_USERNAME}
+ if $ENV{CLEARUSER_USERNAME};
+$CLEAROPTS{CLEARUSER_PASSWORD} = $ENV{CLEARUSER_PASSWORD}
+ if $ENV{CLEARUSER_PASSWORD};
+$CLEAROPTS{CLEARUSER_BASEDN} = $ENV{CLEARUSER_BASEDN}
+ if $ENV{CLEARUSER_BASEDN};
+
+my ($ldap, $ad);
+
+sub unix2sso ($) {
+ my ($unix) = @_;
+
+ my $firstchar = substr $unix, 0, 1;
+ my $secondchar = substr $unix, 1, 1;
+
+ # Crazy mod 36 math!
+ my $num = (ord ($firstchar) - 97) * 36 + (ord ($secondchar) - 97) + 100;
+
+ my $return = $num . substr $unix, 2, 6;
+
+ return $return;
+} # unix2sso
+
+sub GetOwnerInfo ($) {
+ my ($userid) = @_;
+
+ my @parts = split /(\/|\\)/, $userid;
+
+ if (@parts == 3) {
+ $userid = $parts[2];
+ } # if
+
+ my $sso = unix2sso ($userid);
+
+ unless ($ldap) {
+ $ldap = Net::LDAP->new ($CLEAROPTS{CLEARUSER_LDAPHOST})
+ or croak 'Unable to create LDAP object';
+
+ $ad = $ldap->bind (
+ "$CLEAROPTS{CLEARUSER_USERNAME}\@$CLEAROPTS{CLEARUSER_BIND}",
+ password => $CLEAROPTS{CLEARUSER_PASSWORD});
+ } # unless
+
+ $ad = $ldap->search (
+ base => $CLEAROPTS{CLEARUSER_BASEDN},
+ filter => "(&(objectclass=user)(sAMAccountName=$sso))",
+ );
+
+ $ad->code
+ && croak $ad->error;
+
+ my @entries = $ad->entries;
+
+ my %ownerInfo;
+
+ if (@entries == 1) {
+ for (my $i = 0; $i < $ad->count; $i++) {
+ my $entry = $ad->entry ($i);
+
+ foreach my $attribute ($entry->attributes) {
+ $ownerInfo{$attribute} = $entry->get_value ($attribute)
+ } # foreach
+ } # for
+
+ return %ownerInfo;
+ } else {
+ return;
+ } # if
+} # GetOwnerInfo
+
+=pod
+
+=item new ($id)
+
+Returns a new user object based on $id
+
+Parameters:
+
+=begin html
+
+<blockquote>
+
+=end html
+
+=over
+
+=item $id
+
+User identifier
+
+=back
+
+=begin html
+
+</blockquote>
+
+=end html
+
+Returns:
+
+=begin html
+
+<blockquote>
+
+=end html
+
+=over
+
+=item User object
+
+=back
+
+=begin html
+
+</blockquote>
+
+=end html
+
+=cut
+
+sub new ($) {
+ my ($class, $userid) = @_;
+
+ croak "Must specify userid to User constructor"
+ if @_ == 1;
+
+ my %members;
+
+ $members{id} = $userid;
+
+ my %ownerInfo = GetOwnerInfo ($userid);
+
+ $members{$_} = $ownerInfo{$_}
+ foreach (keys %ownerInfo);
+
+ return bless \%members, $class;
+} # new
+
+1;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<Carp>
+
+L<Net::LDAP|Net::LDAP>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ GetConfig
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/GetConfig.pm">GetConfig</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this module
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2010, ClearSCM, Inc. All rights reserved.
+
+=cut
--- /dev/null
+-- -----------------------------------------------------------------------------
+--
+-- File: $RCSfile: clearadm.sql,v $
+-- Revision: $Revision: 1.23 $
+-- Description: Create the clearadm database
+-- Author: Andrew@DeFaria.com
+-- Created: Tue Nov 30 08:46:42 EST 2010
+-- Modified: $Date: 2011/02/09 13:28:33 $
+-- Language: SQL
+--
+-- Copyright (c) 2010, ClearSCM, Inc., all rights reserved
+--
+-- -----------------------------------------------------------------------------
+-- Warning: The following line will delete the old database!
+-- drop database if exists clearadm;
+
+-- Create a new database
+create database clearadm;
+
+-- Now let's focus on this new database
+use clearadm;
+
+-- system: Define what makes up a system or machine
+create table system (
+ name varchar (255) not null,
+ alias varchar (255),
+ active enum (
+ 'true',
+ 'false'
+ ) not null default 'true',
+ admin tinytext,
+ email tinytext,
+ os tinytext,
+ type enum (
+ 'Linux',
+ 'Unix',
+ 'Windows'
+ ) not null,
+ region tinytext,
+ port int default 25327,
+ lastheardfrom datetime,
+ notification varchar (255),
+ description text,
+ loadavgHist enum (
+ '1 month',
+ '2 months',
+ '3 months',
+ '4 months',
+ '5 months',
+ '6 months',
+ '7 months',
+ '8 months',
+ '9 months',
+ '10 months',
+ '11 months',
+ '1 year'
+ ) not null default '6 months',
+ loadavgThreshold float (4,2) default 5.00,
+
+ primary key (name)
+) type=innodb; -- system
+
+-- clearcase: Information about a Clearcase system
+create table clearcase (
+ system varchar (255) not null,
+ ccver tinytext,
+ hardware tinytext,
+ licenseHost tinytext,
+ registryHost tinytext,
+ mvfsBlocksPerDirectory int,
+ mvfsCleartextMnodes int,
+ mvfsDirectoryNames int,
+ mvfsFileNames int,
+ mvfsFreeMnodes int,
+ mvfsInitialMnodeTableSize int,
+ mvfsMinCleartextMnodes int,
+ mvfsMinFreeMnodes int,
+ mvfsNamesNotFound int,
+ mvfsRPCHandles int,
+ interopRegion int,
+ scalingFactor int,
+ cleartextIdleLifetime int,
+ vobHashTableSize int,
+ cleartextHashTableSize int,
+ dncHashTableSize int,
+ threadHashTableSize int,
+ processHashTableSize int,
+
+ foreign key systemLink (system) references system (name)
+ on delete cascade
+ on update cascade,
+ primary key (system)
+) type=innodb; -- clearcase
+
+-- package: A package is any software package that we wish to keep track of
+create table package (
+ system varchar (255) not null,
+ name varchar (255) not null,
+ version tinytext not null,
+ vendor tinytext,
+ description text,
+
+ key packageIndex (name),
+ key systemIndex (system),
+ foreign key systemLink (system) references system (name)
+ on delete cascade
+ on update cascade,
+ primary key (system, name)
+) type=innodb; -- package
+
+-- filesystem: A systems file systems that we are monitoring
+create table filesystem (
+ system varchar (255) not null,
+ filesystem varchar (255) not null,
+ fstype tinytext not null,
+ mount tinytext,
+ threshold int default 90,
+ notification varchar (255),
+ filesystemHist enum (
+ '1 month',
+ '2 months',
+ '3 months',
+ '4 months',
+ '5 months',
+ '6 months',
+ '7 months',
+ '8 months',
+ '9 months',
+ '10 months',
+ '11 months',
+ '1 year'
+ ) not null default '6 months',
+
+ key filesystemIndex (filesystem),
+ foreign key systemLink (system) references system (name)
+ on delete cascade
+ on update cascade,
+ primary key (system, filesystem)
+) type=innodb; -- filesystem
+
+-- fs: Contains a snapshot reading of a filesystem at a given date and time
+create table fs (
+ system varchar(255) not null,
+ filesystem varchar(255) not null,
+ mount varchar(255) not null,
+ timestamp datetime not null,
+ size bigint,
+ used bigint,
+ free bigint,
+ reserve bigint,
+
+ key mountIndex (mount),
+ primary key (system, filesystem, timestamp),
+ foreign key filesystemLink (system, filesystem)
+ references filesystem (system, filesystem)
+ on delete cascade
+ on update cascade
+) type=innodb; -- fs
+
+-- loadavg: Contains a snapshot reading of a system's load average
+create table loadavg (
+ system varchar(255) not null,
+ timestamp datetime not null,
+ uptime tinytext,
+ users int,
+ loadavg float (4,2),
+
+ primary key (system, timestamp).
+ foreign key systemLink (system) references system (name)
+ on delete cascade
+ on update cascade
+) type=innodb; -- loadavg
+
+-- vobs: Describe a system's vobs
+create table vob (
+ system varchar (255) not null,
+ tag varchar (255) not null,
+
+ key systemIndex (system),
+ foreign key systemLink (system) references system (name)
+ on delete cascade
+ on update cascade,
+ primary key (tag)
+) type=innodb; -- vob
+
+-- view: Describe views
+create table view (
+ system varchar (255) not null,
+ region varchar (255) not null,
+ tag varchar (255) not null,
+ owner tinytext,
+ ownerName tinytext,
+ email tinytext,
+ type enum (
+ 'dynamic',
+ 'snapshot',
+ 'web'
+ ) not null default 'dynamic',
+ gpath tinytext,
+ modified datetime,
+ timestamp datetime,
+ age tinytext,
+ ageSuffix tinytext,
+
+ key systemIndex (system),
+ foreign key systemLink (system) references system (name)
+ on delete cascade
+ on update cascade,
+ key regionIndex (region),
+ primary key (region, tag)
+) type=innodb; -- view
+
+create table task (
+ name varchar (255) not null,
+ system varchar (255),
+ description text,
+ command text not null,
+ restartable enum (
+ 'true',
+ 'false'
+ ) not null default 'true',
+
+ primary key (name)
+ foreign key systemLink (system) references system (name)
+ on delete cascade
+ on update cascade,
+) type=innodb; -- task
+
+create table runlog (
+ id int not null auto_increment,
+ task varchar (255) not null,
+ system varchar (255),
+ started datetime,
+ ended datetime,
+ alerted enum (
+ 'true',
+ 'false'
+ ) not null default 'false',
+ status int,
+ message text,
+
+ primary key (id, task, system),
+ foreign key taskLink (task) references task (name)
+ on delete cascade
+ on update cascade
+ foreign key systemLink (system) references system (name)
+ on delete cascade
+ on update cascade
+) type=innodb; -- runlog
+
+create table schedule (
+ name varchar (255) not null,
+ task varchar (255) not null,
+ notification varchar (255) not null,
+ frequency tinytext,
+ active enum (
+ 'true',
+ 'false'
+ ) not null default 'true',
+ lastrunid int,
+
+ primary key (name),
+ foreign key taskLink (task) references task (name)
+ on delete cascade
+ on update cascade
+ foreign key notificationLink (notification) references notification (name)
+ on delete cascade
+ on update cascade
+) type=innodb; -- schedule
+
+create table alert (
+ name varchar (255) not null,
+ type enum (
+ 'email',
+ 'page',
+ 'im'
+ ) not null default 'email',
+ who tinytext,
+
+ primary key (name)
+) type=innodb; -- alert
+
+create table notification (
+ name varchar (255) not null,
+ alert varchar (255) not null,
+ cond tinytext not null,
+ nomorethan enum (
+ 'Once an hour',
+ 'Once a day',
+ 'Once a week',
+ 'Once a month'
+ ) not null default 'Once a day',
+
+ primary key (name),
+ foreign key alertLink (alert) references alert (name)
+ on delete cascade
+ on update cascade,
+ ) type=innodb; -- notification
+
+ create table alertlog (
+ id int not null auto_increment,
+ alert varchar (255) not null,
+ system varchar (255) not null,
+ notification varchar (255) not null,
+ runlog int not null,
+ timestamp datetime,
+ message text,
+
+ primary key (id, alert),
+ key (system),
+ foreign key alertLink (alert) references alert (name)
+ on delete cascade
+ on update cascade,
+ foreign key notificationLink (notification) references notification (name)
+ on delete cascade
+ on update cascade,
+ foreigh key runlogLink (runlog) references runlog (id)
+ on delete cascade
+ on update cascade
+) type=innodb; -- alertlog
\ No newline at end of file
--- /dev/null
+-- -----------------------------------------------------------------------------
+--
+-- File: $RCSfile: load.sql,v $
+-- Revision: $Revision: 1.10 $
+-- Description: Create predefined data in the Clearadm database
+-- Author: Andrew@ClearSCM.com
+-- Created: Tue Nov 30 08:46:42 EST 2010
+-- Modified: $Date: 2012/07/04 20:51:34 $
+-- Language: SQL
+--
+-- Copyright (c) 2010, ClearSCM, Inc., all rights reserved
+--
+-- -----------------------------------------------------------------------------
+-- Predefined alerts
+insert into alert (
+ name,
+ type
+) values (
+ 'Email admin',
+ 'email'
+);
+
+-- Predefined notifications
+insert into notification (
+ name,
+ alert,
+ cond,
+ nomorethan
+) values (
+ 'Filesystem',
+ 'Email admin',
+ 'Filesystem over threshold',
+ 'Once a day'
+);
+
+insert into notification (
+ name,
+ alert,
+ cond,
+ nomorethan
+) values (
+ 'Heartbeat',
+ 'Email admin',
+ 'Heartbeat Failure',
+ 'Once an hour'
+);
+
+insert into notification (
+ name,
+ alert,
+ cond,
+ nomorethan
+) values (
+ 'Loadavg',
+ 'Email admin',
+ 'Loadavg over threshold',
+ 'Once an hour'
+);
+
+insert into notification (
+ name,
+ alert,
+ cond,
+ nomorethan
+) values (
+ 'Scrub',
+ 'Email admin',
+ 'Scrub Failure',
+ 'Once a day'
+);
+
+insert into notification (
+ name,
+ alert,
+ cond,
+ nomorethan
+) values (
+ 'System checkin',
+ 'Email admin',
+ 'Not respoding',
+ 'Once an hour'
+);
+
+insert into notification (
+ name,
+ alert,
+ cond,
+ nomorethan
+) values (
+ 'Update systems',
+ 'Email admin',
+ 'Non zero return',
+ 'Once an hour'
+);
+
+-- Predefined tasks
+insert into task (
+ name,
+ system,
+ description,
+ command,
+) values (
+ 'Loadavg',
+ 'Localhost',
+ 'Obtain a loadavg snapshot on all systems',
+ 'updatela.pl',
+);
+
+insert into task (
+ name,
+ system,
+ description,
+ command,
+) values (
+ 'Filesystem',
+ 'Localhost',
+ 'Obtain a filesystem snapshot on all systems/filesystems',
+ 'updatefs.pl',
+);
+
+insert into task (
+ name,
+ system,
+ description,
+ command
+) values (
+ 'Scrub',
+ 'Localhost',
+ 'Scrub Clearadm database',
+ 'clearadmscrub.pl',
+);
+
+insert into task (
+ name,
+ system,
+ description
+) values (
+ 'System checkin',
+ 'Localhost',
+ 'Checkin from all systems',
+);
+
+insert into task (
+ name,
+ system,
+ description,
+ command
+) values (
+ 'Update systems',
+ 'Localhost',
+ 'Update all systems',
+ 'updatesystem.pl -host all',
+);
+
+-- Predefined schedule
+insert into schedule (
+ name,
+ task,
+ notification,
+ frequency
+) values (
+ 'Loadavg',
+ 'Loadavg',
+ 'LoadAvg',
+ '5 Minutes'
+);
+
+insert into schedule (
+ name,
+ task,
+ notification,
+ frequency
+) values (
+ 'Filesystem',
+ 'Filesystem',
+ 'Filesystem',
+ '5 Minutes'
+);
+
+insert into schedule (
+ name,
+ task,
+ notification,
+ frequency
+) values (
+ 'Scrub',
+ 'Scrub',
+ 'Scrub',
+ '1 day
+);
--- /dev/null
+-- -----------------------------------------------------------------------------
+--
+-- File: $RCSfile: users.sql,v $
+-- Revision: $Revision: 1.1 $
+-- Description: Create users for clearscm
+-- Author: Andrew@ClearSCM.com
+-- Created: Tue Nov 30 08:46:42 EST 2010
+-- Modified: $Date: 2010/12/13 17:16:30 $
+-- Language: SQL
+--
+-- Copyright (c) 2010, ClearSCM, Inc., all rights reserved
+--
+-- -----------------------------------------------------------------------------
+grant all privileges
+ on clearadm.*
+ to clearadm@"%"
+identified by 'clearscm';
+
+grant select
+ on clearadm.*
+ to cleareader@"%"
+identified by 'cleareader';
+
+grant insert, select, update, delete
+ on clearadm.*
+ to clearwriter@"%"
+identified by 'clearwriter';
--- /dev/null
+-- MySQL dump 10.13 Distrib 5.1.41, for debian-linux-gnu (x86_64)
+--
+-- Host: localhost Database: clearadm
+-- ------------------------------------------------------
+-- Server version 5.1.41-3ubuntu12.8
+
+/*!40101 SET @OLD_CHARACTER_SET_CLIENT=@@CHARACTER_SET_CLIENT */;
+/*!40101 SET @OLD_CHARACTER_SET_RESULTS=@@CHARACTER_SET_RESULTS */;
+/*!40101 SET @OLD_COLLATION_CONNECTION=@@COLLATION_CONNECTION */;
+/*!40101 SET NAMES utf8 */;
+/*!40103 SET @OLD_TIME_ZONE=@@TIME_ZONE */;
+/*!40103 SET TIME_ZONE='+00:00' */;
+/*!40014 SET @OLD_UNIQUE_CHECKS=@@UNIQUE_CHECKS, UNIQUE_CHECKS=0 */;
+/*!40014 SET @OLD_FOREIGN_KEY_CHECKS=@@FOREIGN_KEY_CHECKS, FOREIGN_KEY_CHECKS=0 */;
+/*!40101 SET @OLD_SQL_MODE=@@SQL_MODE, SQL_MODE='NO_AUTO_VALUE_ON_ZERO' */;
+/*!40111 SET @OLD_SQL_NOTES=@@SQL_NOTES, SQL_NOTES=0 */;
+
+--
+-- Table structure for table `view`
+--
+
+DROP TABLE IF EXISTS `view`;
+/*!40101 SET @saved_cs_client = @@character_set_client */;
+/*!40101 SET character_set_client = utf8 */;
+CREATE TABLE `view` (
+ `system` varchar(255) NOT NULL,
+ `region` varchar(255) NOT NULL,
+ `tag` varchar(255) NOT NULL,
+ `owner` tinytext,
+ `ownerName` tinytext,
+ `email` tinytext,
+ `type` enum('dynamic','snapshot','web') DEFAULT 'dynamic',
+ `gpath` tinytext,
+ `modified` datetime DEFAULT NULL,
+ `timestamp` datetime DEFAULT NULL,
+ `age` tinytext,
+ `ageSuffix` tinytext,
+ PRIMARY KEY (`region`,`tag`),
+ KEY `systemIndex` (`system`),
+ KEY `regionIndex` (`region`),
+ CONSTRAINT `view_ibfk_1` FOREIGN KEY (`system`) REFERENCES `system` (`name`) ON DELETE CASCADE ON UPDATE CASCADE
+) ENGINE=InnoDB DEFAULT CHARSET=latin1;
+/*!40101 SET character_set_client = @saved_cs_client */;
+
+--
+-- Dumping data for table `view`
+--
+
+LOCK TABLES `view` WRITE;
+/*!40000 ALTER TABLE `view` DISABLE KEYS */;
+INSERT INTO `view` VALUES ('jupiter','home','tomsview1','defaria','Tom Connor','TomHillConnor@yahoo.com','web','/views/tconnor/tomsview1.vws','2010-12-25 00:00:00','2011-01-01 10:10:10','30','days'),('jupiter','home','tomsview2','defaria','Tom Connor','TomHillConnor@yahoo.com','snapshot','/views/tconnor/tomsview2.vws','2010-12-25 00:00:00','2011-01-01 10:10:10','45','days'),('jupiter','home','view1','defaria','Andrew DeFaria','Andrew@DeFaria.com','dynamic','/views/defaria/view1.vws','2010-01-01 00:00:00','2011-01-01 10:10:10','350','days'),('earth','home','view2','defaria','Andrew DeFaria','Andrew@DeFaria.com','snapshot','/views/defaria/view2.vws','2010-06-28 00:00:00','2011-01-01 10:10:10','210','days'),('jupiter','home','view3','defaria','Andrew DeFaria','Andrew@DeFaria.com','snapshot','/views/defaria/view3.vws','2010-12-25 00:00:00','2011-01-01 10:10:10','30','days');
+/*!40000 ALTER TABLE `view` ENABLE KEYS */;
+UNLOCK TABLES;
+/*!40103 SET TIME_ZONE=@OLD_TIME_ZONE */;
+
+/*!40101 SET SQL_MODE=@OLD_SQL_MODE */;
+/*!40014 SET FOREIGN_KEY_CHECKS=@OLD_FOREIGN_KEY_CHECKS */;
+/*!40014 SET UNIQUE_CHECKS=@OLD_UNIQUE_CHECKS */;
+/*!40101 SET CHARACTER_SET_CLIENT=@OLD_CHARACTER_SET_CLIENT */;
+/*!40101 SET CHARACTER_SET_RESULTS=@OLD_CHARACTER_SET_RESULTS */;
+/*!40101 SET COLLATION_CONNECTION=@OLD_COLLATION_CONNECTION */;
+/*!40111 SET SQL_NOTES=@OLD_SQL_NOTES */;
+
+-- Dump completed on 2011-01-13 18:37:26
--- /dev/null
+option explicit
+
+sub display (msg)
+ wscript.echo msg
+end sub
+
+sub checkError (msg)
+ if err.number = 0 then
+ exit sub
+ end if
+
+ display "Error " & err.number & ": " & msg
+
+ if err.description <> "" then
+ display err.description
+ end if
+
+ wscript.quit err.number
+end sub
+
+dim net, server, service, enumerator, instance, loadavg, locator, namespace
+
+' Get localhost's name
+set net = CreateObject ("Wscript.Network")
+server = net.ComputerName
+
+set locator = CreateObject ("WbemScripting.SWbemLocator")
+
+checkError "Unable to create locator object"
+
+' Connect to the namespace which is either local or remote
+set service = locator.ConnectServer (server, namespace, "", "")
+
+checkError "Unable to connect to server " & server
+
+service.Security_.impersonationlevel = 3
+
+set enumerator = service.InstancesOf ("Win32_Processor")
+
+checkError "Unable to query Win32_Processor"
+
+loadavg = 0
+
+for each instance in enumerator
+ if not (instance is nothing) then
+ if instance.LoadPercentage <> "" then
+ loadavg = loadavg + instance.LoadPercentage
+ end if
+ end if
+next
+
+display loadavg
--- /dev/null
+clearagent.pl V1.11 started at Wed May 1 16:07:48 2013
+20130501@16:07:48 Clearexec V1.18 accepting clients at Wed May 1 16:07:48 2013
+clearagent.pl V1.11 started at Wed May 1 16:10:03 2013
+20130501@16:10:03 Clearexec V1.18 accepting clients at Wed May 1 16:10:03 2013
+clearagent.pl V1.11 started at Wed May 1 16:12:57 2013
+20130501@16:12:57 Clearexec V1.18 accepting clients at Wed May 1 16:12:57 2013
+Argument "no" isn't numeric in numeric le (<=) at /opt/clearscm/clearadm/../lib/Display.pm line 1059.
+clearagent.pl V1.11 started at Wed May 1 16:18:03 2013
+20130501@16:18:03 Clearexec V1.18 accepting clients at Wed May 1 16:18:03 2013
+clearagent.pl V1.11 started at Wed May 1 16:20:52 2013
+20130501@16:20:52 Clearexec V1.18 accepting clients at Wed May 1 16:20:52 2013
+clearagent.pl V1.11 started at Wed May 1 16:26:45 2013
+20130501@16:26:45 Clearexec V1.18 accepting clients at Wed May 1 16:26:45 2013
+clearagent.pl V1.11 started at Wed May 1 16:34:21 2013
+20130501@16:34:21 Clearexec V1.18 accepting clients at Wed May 1 16:34:21 2013
+clearagent.pl V1.11 started at Wed May 1 16:42:10 2013
+20130501@16:42:10 Clearexec V1.18 accepting clients at Wed May 1 16:42:10 2013
+clearagent.pl V1.11 started at Wed May 1 16:43:50 2013
+20130501@16:43:50 Clearexec V1.18 accepting clients at Wed May 1 16:43:50 2013
+clearagent.pl V1.11 started at Thu May 2 10:28:22 2013
+20130502@10:28:22 Clearexec V1.18 accepting clients at Thu May 2 10:28:22 2013
+Argument "no" isn't numeric in numeric le (<=) at /opt/clearscm/clearadm/../lib/Display.pm line 1059.
+clearagent.pl V1.11 started at Sat May 4 18:42:54 2013
+20130504@18:42:54 Clearexec V1.18 accepting clients at Sat May 4 18:42:54 2013
+Argument "no" isn't numeric in numeric le (<=) at /opt/clearscm/clearadm/../lib/Display.pm line 1059.
+clearagent.pl V1.11 started at Sat May 4 18:47:10 2013
+20130504@18:47:10 Clearexec V1.18 accepting clients at Sat May 4 18:47:10 2013
+clearagent.pl V1.11 started at Sat May 4 18:48:51 2013
+20130504@18:48:51 Clearexec V1.18 accepting clients at Sat May 4 18:48:51 2013
+clearagent.pl V1.11 started at Sat May 4 18:56:10 2013
+20130504@18:56:10 Clearexec V1.18 accepting clients at Sat May 4 18:56:10 2013
+clearagent.pl V1.11 started at Sat May 4 19:31:58 2013
+20130504@19:31:58 Clearexec V1.18 accepting clients at Sat May 4 19:31:58 2013
+clearagent.pl V1.11 started at Sat May 4 19:33:36 2013
+20130504@19:33:36 Clearexec V1.18 accepting clients at Sat May 4 19:33:36 2013
+clearagent.pl V1.11 started at Tue May 7 11:05:07 2013
+20130507@11:05:07 Clearexec V1.18 accepting clients at Tue May 7 11:05:07 2013
+clearagent.pl V1.11 started at Wed May 8 11:16:35 2013
+20130508@11:16:35 Clearexec V1.18 accepting clients at Wed May 8 11:16:35 2013
+Argument "no" isn't numeric in numeric le (<=) at /opt/clearscm/clearadm/../lib/Display.pm line 1059.
+clearagent.pl V1.11 started at Wed May 8 13:42:50 2013
+20130508@13:42:50 Clearexec V1.18 accepting clients at Wed May 8 13:42:50 2013
+clearagent.pl V1.11 started at Thu May 9 11:00:46 2013
+20130509@11:00:46 Clearexec V1.18 accepting clients at Thu May 9 11:00:46 2013
+clearagent.pl V1.11 started at Fri May 10 08:07:53 2013
+20130510@08:07:53 Clearexec V1.18 accepting clients at Fri May 10 08:07:53 2013
+clearagent.pl V1.11 started at Fri May 10 08:50:10 2013
+20130510@08:50:10 Clearexec V1.18 accepting clients at Fri May 10 08:50:10 2013
+Argument "no" isn't numeric in numeric le (<=) at /opt/clearscm/clearadm/../lib/Display.pm line 1059.
+clearagent.pl V1.11 started at Sun May 12 18:23:55 2013
+20130512@18:23:55 Clearexec V1.18 accepting clients at Sun May 12 18:23:55 2013
+Argument "no" isn't numeric in numeric le (<=) at /opt/clearscm/clearadm/../lib/Display.pm line 1059.
+clearagent.pl V1.11 started at Mon May 13 14:38:22 2013
+20130513@14:38:22 Clearexec V1.18 accepting clients at Mon May 13 14:38:22 2013
+Argument "no" isn't numeric in numeric le (<=) at /opt/clearscm/clearadm/../lib/Display.pm line 1059.
+clearagent.pl V1.11 started at Sun May 19 07:08:23 2013
+20130519@07:08:23 Clearexec V1.18 accepting clients at Sun May 19 07:08:23 2013
+Argument "no" isn't numeric in numeric le (<=) at /opt/clearscm/clearadm/../lib/Display.pm line 1059.
+clearagent.pl V1.11 started at Tue May 28 08:35:48 2013
+20130528@08:35:48 Clearexec V1.18 accepting clients at Tue May 28 08:35:48 2013
+Argument "no" isn't numeric in numeric le (<=) at /opt/clearscm/clearadm/../lib/Display.pm line 1059.
+clearagent.pl V1.11 started at Thu May 30 21:10:08 2013
+20130530@21:10:08 Clearexec V1.18 accepting clients at Thu May 30 21:10:08 2013
+clearagent.pl V1.11 started at Thu May 30 21:12:44 2013
+20130530@21:12:44 Clearexec V1.18 accepting clients at Thu May 30 21:12:44 2013
+Argument "no" isn't numeric in numeric le (<=) at /opt/clearscm/clearadm/../lib/Display.pm line 1059.
+clearagent.pl V1.11 started at Sun Jun 9 16:22:12 2013
+20130609@16:22:12 Clearexec V1.18 accepting clients at Sun Jun 9 16:22:12 2013
+Argument "no" isn't numeric in numeric le (<=) at /opt/clearscm/clearadm/../lib/Display.pm line 1059.
+clearagent.pl V1.11 started at Mon Jun 10 17:08:33 2013
+20130610@17:08:33 Clearexec V1.18 accepting clients at Mon Jun 10 17:08:33 2013
+clearagent.pl V1.11 started at Mon Jun 10 17:35:40 2013
+20130610@17:35:40 Clearexec V1.18 accepting clients at Mon Jun 10 17:35:40 2013
+clearagent.pl V1.11 started at Mon Jun 10 17:38:04 2013
+20130610@17:38:04 Clearexec V1.18 accepting clients at Mon Jun 10 17:38:04 2013
+clearagent.pl V1.11 started at Mon Jun 10 17:40:14 2013
+20130610@17:40:14 Clearexec V1.18 accepting clients at Mon Jun 10 17:40:14 2013
+Argument "no" isn't numeric in numeric le (<=) at /opt/clearscm/clearadm/../lib/Display.pm line 1059.
+clearagent.pl V1.11 started at Thu Jun 13 13:52:55 2013
+20130613@13:52:55 Clearexec V1.18 accepting clients at Thu Jun 13 13:52:55 2013
+Argument "no" isn't numeric in numeric le (<=) at /opt/clearscm/clearadm/../lib/Display.pm line 1059.
+clearagent: ERROR #1: Could not create socket - Address already in use
+clearagent.pl V1.11 started at Fri Jun 14 09:23:49 2013
+clearagent.pl V1.11 started at Sat Jun 15 11:25:56 2013
+20130615@11:25:56 Clearexec V1.18 accepting clients at Sat Jun 15 11:25:56 2013
+Argument "no" isn't numeric in numeric le (<=) at /opt/clearscm/clearadm/../lib/Display.pm line 1059.
+clearagent.pl V1.11 started at Wed Jun 19 09:47:28 2013
+20130619@09:47:28 Clearexec V1.18 accepting clients at Wed Jun 19 09:47:28 2013
+Argument "no" isn't numeric in numeric le (<=) at /opt/clearscm/clearadm/../lib/Display.pm line 1059.
+clearagent.pl V1.11 started at Wed Jul 10 13:32:54 2013
+20130710@13:32:54 Clearexec V1.18 accepting clients at Wed Jul 10 13:32:54 2013
--- /dev/null
+cleartasks.pl V1.25 started at Wed Jun 19 12:32:28 2013
+updatela: ERROR: 20130621@16:42:53 System: earth Loadavg 5.15 Threshold 5.00
+updatela: ERROR: 20130624@08:20:10 System: earth Loadavg 5.54 Threshold 5.00
+updatela: ERROR #1: Unable to connect to system mars:25327
+cleartasks.pl V1.25 started at Mon Jun 24 12:18:10 2013
+cleartasks: ERROR: 20130628@12:48:27: Unable to talk to DB server.
+
+Clearadm::_getRecords: Unable to execute statement
+Error #2006: MySQL server has gone away
+SQL Statement: select * from system where name like '%%' or alias like '%%'
+
+Will try again in 30 seconds
+cleartasks: ERROR: 20130629@12:49:00: Unable to talk to DB server.
+
+Clearadm::_getRecords: Unable to execute statement
+Error #2006: MySQL server has gone away
+SQL Statement: select * from system where name like '%%' or alias like '%%'
+
+Will try again in 30 seconds
+cleartasks: ERROR: 20130630@12:49:32: Unable to talk to DB server.
+
+Clearadm::_getRecords: Unable to execute statement
+Error #2006: MySQL server has gone away
+SQL Statement: select * from system where name like '%%' or alias like '%%'
+
+Will try again in 30 seconds
+cleartasks: ERROR: 20130701@12:50:04: Unable to talk to DB server.
+
+Clearadm::_getRecords: Unable to execute statement
+Error #2006: MySQL server has gone away
+SQL Statement: select * from system where name like '%%' or alias like '%%'
+
+Will try again in 30 seconds
+cleartasks: ERROR: 20130702@12:50:37: Unable to talk to DB server.
+
+Clearadm::_getRecords: Unable to execute statement
+Error #2006: MySQL server has gone away
+SQL Statement: select * from system where name like '%%' or alias like '%%'
+
+Will try again in 30 seconds
+cleartasks.pl V1.25 started at Wed Jul 3 10:44:00 2013
+updatela: ERROR: 20130703@17:27:52 System: earth Loadavg 5.13 Threshold 5.00
+updatela: ERROR #1: Unable to connect to system neptune:25327
+updatela: ERROR: 20130708@03:40:20 System: earth Loadavg 5.43 Threshold 5.00
+updatela: ERROR: 20130708@08:25:53 System: earth Loadavg 5.04 Threshold 5.00
+cleartasks: ERROR: 20130709@12:54:29: Unable to talk to DB server.
+
+Clearadm::_getRecords: Unable to execute statement
+Error #2006: MySQL server has gone away
+SQL Statement: select * from system where name like '%%' or alias like '%%'
+
+Will try again in 30 seconds
+cleartasks: ERROR: 20130710@12:55:01: Unable to talk to DB server.
+
+Clearadm::_getRecords: Unable to execute statement
+Error #2006: MySQL server has gone away
+SQL Statement: select * from system where name like '%%' or alias like '%%'
+
+Will try again in 30 seconds
+updatela: ERROR: 20130710@12:55:32 System: earth Loadavg 9.53 Threshold 5.00
+cleartasks.pl V1.25 started at Wed Jul 10 13:32:54 2013
+Couldn't connect to clearadm database as clearwriter@earth at /opt/clearscm/clearadm/cleartasks.pl line 510
--- /dev/null
+I've created packages.vbs to get the packages from a Windows system. Output
+basically looks like this:
+
+Name: Acrobat.com
+Version: 1.6.65
+Vendor: Adobe Systems Incorporated
+Description: Acrobat.com
+
+To do roughly the same for Linux (Well debain based Linux):
+
+$ dpkg-query -W -f='Name: ${Package}\nVersion: ${Version}\nVendor: ${Vendor}\nDescription: ${Description}\n'
+
+Which produces output like:
+
+Name: alien
+Version: 8.79ubuntu0.1
+Vendor:
+Description: convert and install rpm and other packages
+ Alien allows you to convert LSB, Red Hat, Stampede and Slackware Packages
+ into Debian packages, which can be installed with dpkg.
+ .
+ It can also generate packages of any of the other formats.
+ .
+ This is a tool only suitable for binary packages.
+
+I don't have a Redhat system to see how to get similar output from there. Then
+there's Sun, HP-UX, etc...
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: notifications.cgi,v $
+
+Display notifications
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.5 $
+
+=item Created:
+
+Mon Oct 25 11:10:47 PDT 2008
+
+=item Modified:
+
+$Date: 2011/01/24 13:51:22 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage notifications.cgi: [-u|sage] [-ve|rbose] [-d|ebug]
+
+ Where:
+ -u|sage: Displays usage
+ -ve|rbose: Be verbose
+ -d|ebug: Output debug messages
+
+=head2 DESCRIPTION
+
+This script displays notifications
+
+=cut
+
+use strict;
+use warnings;
+
+use FindBin;
+use Getopt::Long;
+use CGI qw (:standard :cgi-lib *table start_Tr end_Tr);
+use CGI::Carp 'fatalsToBrowser';
+
+use lib "$FindBin::Bin/lib", "$FindBin::Bin/../lib";
+
+use Clearadm;
+use ClearadmWeb;
+use Display;
+use Utils;
+
+my $VERSION = '$Revision: 1.5 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+my $clearadm;
+
+my %opts = Vars;
+
+# Main
+GetOptions (
+ usage => sub { Usage },
+ verbose => sub { set_verbose },
+ debug => sub { set_debug },
+) or Usage 'Invalid parameter';
+
+# Announce ourselves
+verbose "$FindBin::Script v$VERSION";
+
+$clearadm = Clearadm->new;
+
+my $title = $opts{notification}
+ ? "Notifications matching $opts{notification}"
+ : 'Notifications';
+
+heading $title;
+
+display h1 {class => 'center'}, $title;
+
+displayNotification ($opts{notification});
+
+footing;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<CGI>
+
+L<CGI::Carp|CGI::Carp>
+
+L<FindBin>
+
+L<Getopt::Long|Getopt::Long>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ Clearadm
+ ClearadmWeb
+ Display
+ Utils
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/Clearadm.pm">Clearadm</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/ClearadmWeb.pm">ClearadmWeb</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Utils.pm">Utils</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this script
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2010, ClearSCM, Inc. All rights reserved.
+
+=cut
\ No newline at end of file
--- /dev/null
+sub display (msg)
+ wscript.echo msg
+end sub
+
+host = "."
+
+set wmi = GetObject ("winmgmts:\\" & host & "\root\cimv2")
+set packages = wmi.ExecQuery ("Select * from Win32_Product",, 48)
+
+for each package in packages
+ display "Name: " & package.Name
+ display "Version: " & package.Version
+ display "Vendor: " & package.Vendor
+ display "Description: " & package.Description
+ display "-------------------------------------------------------------------------------"
+next
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: plot.cgi,v $
+
+Plot statistics
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.14 $
+
+=item Created:
+
+Mon Oct 25 11:10:47 PDT 2008
+
+=item Modified:
+
+$Date: 2011/01/28 21:30:45 $
+
+=back
+
+=head1 DESCRIPTION
+
+Display a graph of either Loadavg or Filesystem data and provide controls for
+the user to manipulate the chart.
+
+=cut
+
+use strict;
+use warnings;
+
+use FindBin;
+use CGI qw (:standard :cgi-lib start_table end_table start_Tr end_Tr);
+use GD::Graph::area;
+
+use lib "$FindBin::Bin/lib", "$FindBin::Bin/../lib";
+
+use Clearadm;
+use ClearadmWeb;
+use Display;
+
+my $VERSION = '$Revision: 1.14 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+my %opts = Vars;
+
+my $clearadm;
+
+sub displayGraph () {
+ my $parms;
+
+ foreach (keys %opts) {
+ $parms .= '&'
+ if $parms;
+ $parms .= "$_=$opts{$_}"
+ } # foreach
+
+ display '<center>';
+
+ if ($opts{type} eq 'loadavg') {
+ unless ($opts{tiny}) {
+ display img {src => "plotloadavg.cgi?$parms", class => 'chart'};
+ } else {
+ display img {src => "plotloadavg.cgi?$parms", border => 0};
+ } # unless
+ } elsif ($opts{type} eq 'filesystem') {
+ unless ($opts{tiny}) {
+ display img {src => "plotfs.cgi?$parms", class => 'chart'};
+ } else {
+ display img {src => "plotfs.cgi?$parms", border => 0};
+ } # unless
+ } # if
+
+ display '</center>';
+
+ return
+} # displayGraph
+
+sub displayFSInfo () {
+ if ($opts{filesystem}) {
+ display h3 {-align => 'center'}, 'Latest Filesystem Reading';
+ } else {
+ display p;
+ return;
+ } # if
+
+ display start_table {width => '800px', cellspacing => 1};
+
+ display start_Tr;
+ display th {class => 'labelCentered'}, 'Filesystem';
+ display th {class => 'labelCentered'}, 'Type';
+ display th {class => 'labelCentered'}, 'Mount';
+ display th {class => 'labelCentered'}, 'Size';
+ display th {class => 'labelCentered'}, 'Used';
+ display th {class => 'labelCentered'}, 'Free';
+ display th {class => 'labelCentered'}, 'Used %';
+ display th {class => 'labelCentered'}, 'History';
+ display th {class => 'labelCentered'}, 'Threshold';
+ display end_Tr;
+
+ my %filesystem = $clearadm->GetFilesystem (
+ $opts{system},
+ $opts{filesystem}
+ );
+ my %fs = $clearadm->GetLatestFS (
+ $opts{system},
+ $opts{filesystem}
+ );
+
+ my $size = autoScale $fs{size};
+ my $used = autoScale $fs{used};
+ my $free = autoScale $fs{free};
+
+ display start_Tr;
+ display td {class => 'data'}, $filesystem{filesystem};
+ display td {class => 'dataCentered'}, $filesystem{fstype};
+ display td {class => 'data'}, $filesystem{mount};
+ display td {class => 'dataRight'}, $size;
+ display td {class => 'dataRight'}, $used;
+ display td {class => 'dataRight'}, $free;
+ # TODO: Note that this percentages does not agree with df output. I'm not
+ # sure why.
+ display td {class => 'dataCentered'},
+ sprintf ('%.0f%%', (($fs{reserve} + $fs{used}) / $fs{size} * 100));
+ display td {class => 'dataCentered'}, $filesystem{filesystemHist};
+ display td {class => 'dataCentered'}, "$filesystem{threshold}%";
+ display end_Tr;
+
+ display end_table;
+
+ return;
+} # displayInfo
+
+sub displayControls () {
+ my $class = $opts{type} =~ /loadavg/i
+ ? 'controls'
+ : 'filesystemControls';
+
+ display start_table {
+ align => 'center',
+ class => $class,
+ cellspacing => 0,
+ width => '800px',
+ };
+
+ my $systemLink = span {id => 'systemLink'}, a {
+ href => "systemdetails.cgi?system=$opts{system}",
+ }, 'System';
+
+ my $systemButtons = makeSystemDropdown (
+ $systemLink,
+ $opts{system},
+ 'updateFilesystems(this.value);updateSystemLink(this.value)'
+ );
+
+ my $startButtons = makeTimeDropdown (
+ $opts{type},
+ 'startTimestamp',
+ $opts{system},
+ $opts{filesystem},
+ 'Start',
+ $opts{start},
+ $opts{scaling},
+ );
+
+ my $endButtons = makeTimeDropdown (
+ $opts{type},
+ 'endTimestamp',
+ $opts{system},
+ $opts{filesystem},
+ 'End',
+ $opts{end},
+ $opts{scaling},
+ );
+
+ my $update = $opts{type} eq 'loadavg'
+ ? "updateSystem('$opts{system}')"
+ : "updateFilesystem('$opts{system}','$opts{filesystem}')";
+
+ my $intervalButtons = makeIntervalDropdown (
+ 'Interval',
+ $opts{scaling},
+ $update
+ );
+
+ display start_Tr;
+ display td $startButtons;
+ display td $intervalButtons;
+ display td $systemButtons;
+ display end_Tr;
+
+ display start_Tr;
+ display td $endButtons;
+ display td 'Points',
+ input {
+ name => 'points',
+ value => $opts{points},
+ class => 'inputfield',
+ size => 7,
+ style => 'text-align: right',
+ maxlength => 7,
+ };
+
+ if ($opts{type} eq 'loadavg') {
+ display td input {
+ type => 'submit',
+ value => 'Draw Graph',
+ };
+ } else {
+ my $filesystemButtons = makeFilesystemDropdown (
+ $opts{system},
+ 'Filesystem',
+ undef,
+ "updateFilesystem('$opts{system}',this.value)",
+ );
+
+ display td $filesystemButtons;
+
+ display end_Tr;
+ display start_Tr;
+ display td {align => 'center', colspan => 3},
+ input {type => 'submit', value => 'Draw Graph'};
+ } # if
+
+ display end_Tr;
+
+ display end_table;
+
+ return;
+} # displayControls
+
+$clearadm = Clearadm->new;
+
+my $title = ucfirst ($opts{type}) . ': ' . ucfirst $opts{system};
+
+$title .= ":$opts{filesystem}"
+ if $opts{filesystem};
+
+heading $title;
+
+display h1 {class => 'center'}, $title;
+
+display start_form {
+ method => 'get',
+ action => 'plot.cgi',
+};
+
+# Some hidden fields to pass along
+display input {type => 'hidden', name => 'type', value => $opts{type}};
+
+displayGraph;
+displayFSInfo;
+displayControls;
+
+display end_form;
+
+footing;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<CGI>
+
+L<CGI::Carp|CGI::Carp>
+
+L<FindBin>
+
+L<Getopt::Long|Getopt::Long>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ Clearadm
+ ClearadmWeb
+ Display
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/Clearadm.pm">Clearadm</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/ClearadmWeb.pm">ClearadmWeb</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this script
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2010, ClearSCM, Inc. All rights reserved.
+
+=cut
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: plotfs.cgi,v $
+
+Plot Filesystem usage
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.13 $
+
+=item Created:
+
+Mon Dec 13 09:13:27 EST 2010
+
+=item Modified:
+
+$Date: 2011/01/14 16:37:04 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage plotfs.cgi: system=<system> filesytem=<filesystem>
+ [height=<height>] [width=<width>] [color=<color>]
+ [scaling=<scaling>] [points=<points>] [tiny=<0|1>]
+
+ Where:
+ <system>: Name of the system defined in the Clearadm database to
+ retrieve filesystem snapshots for.
+ <filesystem>: Name of the filesytem to plot information for
+ <height>: Height of chart (Default: 480px - tiny: 40)
+ <width>: Width of chart (Default: 800px - tiny: 150)
+ <color>: A GD::Color color value (Default: lblue)
+ <scaling>: Currently one of Minute, Hour, Day or Month. Specifies how
+ Clearadm::GetFS will scale the data returned (Default: Minute
+ - tiny: Day)
+ <points>: Number of points to plot (Default: all points - tiny: 7)
+
+=head1 DESCRIPTION
+
+Draws a chart of the filesystem usage for the system and filesystem passed in.
+Parameters such as height, width, color, scaling and points can be set
+individually though more often the user will just use the web controls to set
+them. Defaults produce a nice chart. Tiny mode is used by systemdetails.cgi to
+draw tiny charts in the table. Setting tiny sets a number of the other chart
+options to produce a standard, tiny chart.
+
+=cut
+
+use strict;
+use warnings;
+
+use FindBin;
+
+use lib "$FindBin::Bin/lib", "$FindBin::Bin/../lib";
+
+use Clearadm;
+use ClearadmWeb;
+use Display;
+
+use CGI qw (:standard :cgi-lib);
+use GD::Graph::area;
+
+my %opts = Vars;
+
+my $VERSION = '$Revision: 1.13 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+$opts{color} ||= 'lblue';
+$opts{height} ||= 350;
+$opts{width} ||= 800;
+
+if ($opts{tiny}) {
+ $opts{height} = 40;
+ $opts{width} = 150;
+ $opts{points} = 7;
+ $opts{scaling} = 'Day';
+} # if
+
+sub labelY ($) {
+ my ($value) = @_;
+
+ return $opts{tiny} ? '' : $value;
+} # labelY
+
+my $clearadm = Clearadm->new;
+
+my $graph = GD::Graph::area->new ($opts{width}, $opts{height});
+
+graphError "System is required"
+ unless $opts{system};
+
+graphError "Filesystem is required"
+ unless $opts{filesystem};
+
+graphError "Points not numeric (points: $opts{points})"
+ if $opts{points} and $opts{points} !~ /^\d+$/;
+
+my @fs = $clearadm->GetFS (
+ $opts{system},
+ $opts{filesystem},
+ $opts{start},
+ $opts{end},
+ $opts{points},
+ $opts{scaling}
+);
+
+graphError "No data found for $opts{system}:$opts{filesystem}"
+ unless @fs;
+
+my (@x, @y);
+
+my $i = 0;
+
+foreach (@fs) {
+ $i++;
+ my %fs = %{$_};
+
+ if ($opts{tiny}) {
+ push @x, '';
+ } else {
+ push @x, $fs{timestamp};
+ } # if
+
+ push @y, sprintf ('%.2f', $fs{used} / (1024 * 1024));
+}
+my @data = ([@x], [@y]);
+
+my $x_label_skip = @x > 1000 ? 200
+ : @x > 100 ? 20
+ : @x > 50 ? 2
+ : @x > 10 ? 1
+ : 0;
+
+my $x_label = $opts{tiny} ? '' : 'Filesystem Usage';
+my $y_label = $opts{tiny} ? '' : 'Used (Meg)';
+my $title = $opts{tiny} ? '' : "Filesystem usage for "
+ . "$opts{system}:$opts{filesystem}";
+
+$graph->set (
+ x_label =>$x_label,
+ x_labels_vertical => 1,
+ x_label_skip => $x_label_skip,
+ x_label_position => .5,
+ y_label => $y_label,
+ y_number_format => &labelY,
+ title => $title,
+ dclrs => [$opts{color}],
+ bgclr => 'white',
+ transparent => 0,
+ long_ticks => 1,
+ t_margin => 5,
+ b_margin => 5,
+ l_margin => 5,
+ r_margin => 5,
+) or graphError $graph->error;
+
+my $image = $graph->plot(\@data)
+ or croak $graph->error;
+
+print "Content-type: image/png\n\n";
+print $image->png;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<CGI>
+
+L<FindBin>
+
+L<Getopt::Long|Getopt::Long>
+
+L<GD::Graph::area|GD::Graph::area>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ Clearadm
+ ClearadmWeb
+ Display
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/Clearadm.pm">Clearadm</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/ClearadmWeb.pm">ClearadmWeb</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this script
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2010, ClearSCM, Inc. All rights reserved.
+
+=cut
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: plotloadavg.cgi,v $
+
+Plot loadavg for a system
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.15 $
+
+=item Created:
+
+Mon Dec 13 09:13:27 EST 2010
+
+=item Modified:
+
+$Date: 2011/01/20 14:34:24 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage plotfs.cgi: system=<system>
+ [height=<height>] [width=<width>] [color=<color>]
+ [scaling=<scaling>] [points=<points>] [tiny=<0|1>]
+
+ Where:
+ <system>: Name of the system defined in the Clearadm database to
+ retrieve loadavgs snapshots for.
+ <height>: Height of chart (Default: 480px - tiny: 40)
+ <width>: Width of chart (Default: 800px - tiny: 150)
+ <color>: A GD::Color color value (Default: lblue)
+ <scaling>: Currently one of Minute, Hour, Day or Month. Specifies how
+ Clearadm::GetFS will scale the data returned (Default: Minute
+ - tiny: Day)
+ <points>: Number of points to plot (Default: all points - tiny: 7)
+
+=head1 DESCRIPTION
+
+Draws a chart of loadavg for the system passed in. Parameters such as height,
+width, color, scaling and points can be set individually though more often the
+user will just use the web controls to set them. Defaults produce a nice chart.
+Tiny mode is used by systemdetails.cgi to draw tiny charts in the table. Setting
+tiny sets a number of the other chart options to produce a standard, tiny chart.
+
+=cut
+
+use strict;
+use warnings;
+
+use FindBin;
+
+use lib "$FindBin::Bin/lib", "$FindBin::Bin/../lib";
+
+use Clearadm;
+use ClearadmWeb;
+use Display;
+
+use CGI qw (:standard :cgi-lib);
+use GD::Graph::area;
+
+my %opts = Vars;
+
+my $VERSION = '$Revision: 1.15 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+$opts{color} ||= 'lyellow';
+$opts{height} ||= 400;
+$opts{width} ||= 800;
+
+if ($opts{tiny}) {
+ $opts{height} = 40;
+ $opts{width} = 150;
+ $opts{points} = 24;
+ $opts{scaling} = 'Hour';
+} # if
+
+sub labelY ($) {
+ my ($value) = @_;
+
+ return $opts{tiny} ? '' : $value;
+} # labelY
+
+my $clearadm = Clearadm->new;
+
+my $graph = GD::Graph::area->new ($opts{width}, $opts{height});
+
+graphError "System is required"
+ unless $opts{system};
+
+graphError "Points not numeric (points: $opts{points})"
+ if $opts{points} and $opts{points} !~ /^\d+$/;
+
+my @loads = $clearadm->GetLoadavg (
+ $opts{system},
+ $opts{start},
+ $opts{end},
+ $opts{points},
+ $opts{scaling}
+);
+
+graphError "No loadavg data found for system $opts{system}"
+ unless @loads;
+
+my (@x, @y);
+
+foreach (@loads) {
+ my %load = %{$_};
+
+ if ($opts{tiny}) {
+ push @x, '';
+ } else {
+ push @x, $load{timestamp};
+ } # if
+
+ push @y, $load{loadavg};
+} # foreach
+
+my @data = ([@x], [@y]);
+
+my $x_label_skip = @x > 1000 ? 200
+ : @x > 100 ? 20
+ : @x > 50 ? 2
+ : @x > 10 ? 1
+ : 0;
+
+my $x_label = $opts{tiny} ? '' : 'Time';
+my $y_label = $opts{tiny} ? '' : 'Load';
+my $title = $opts{tiny} ? '' : "Load Average for $opts{system}";
+
+$graph->set (
+ x_label => $x_label,
+ x_labels_vertical => 1,
+ x_label_skip => $x_label_skip,
+ x_label_position => .5,
+ y_label => $y_label,
+ y_number_format => &labelY,
+ title => $title,
+ dclrs => [$opts{color}],
+ bgclr => 'white',
+ transparent => 0,
+ long_ticks => 1,
+ t_margin => 5,
+ b_margin => 5,
+ l_margin => 5,
+ r_margin => 5,
+) or graphError $graph->error;
+
+my $image = $graph->plot(\@data)
+ or croak $graph->error;
+
+print "Content-type: image/png\n\n";
+print $image->png;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<CGI>
+
+L<FindBin>
+
+L<GD::Graph::area|GD::Graph::area>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ Clearadm
+ ClearadmWeb
+ Display
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/Clearadm.pm">Clearadm</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/ClearadmWeb.pm">ClearadmWeb</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this script
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2010, ClearSCM, Inc. All rights reserved.
+
+=cut
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: processalert.cgi,v $
+
+Process an alert
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.3 $
+
+=item Created:
+
+Mon Oct 25 11:10:47 PDT 2008
+
+=item Modified:
+
+$Date: 2011/02/14 14:51:54 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage processalert.cgi: [-u|sage] [-ve|rbose] [-d|ebug]
+ action=[Add|Delete|Edit|Post] alert=<alertname>
+
+ Where:
+ -u|sage: Displays usage
+ -ve|rbose: Be verbose
+ -d|ebug: Output debug messages
+
+ action: Specifies to add, delete, edit or post an alert
+ alert: Name of alert to delete or edit
+
+=head2 DESCRIPTION
+
+This script adds, deletes, edits or posts an alert
+
+=cut
+
+use strict;
+use warnings;
+
+use FindBin;
+use Getopt::Long;
+use CGI qw (:standard :cgi-lib *table start_Tr end_Tr);
+use CGI::Carp 'fatalsToBrowser';
+
+use lib "$FindBin::Bin/lib", "$FindBin::Bin/../lib";
+
+use Clearadm;
+use ClearadmWeb;
+use Display;
+use Utils;
+
+my $VERSION = '$Revision: 1.3 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+my $clearadm;
+
+# Main
+GetOptions (
+ usage => sub { Usage },
+ verbose => sub { set_verbose },
+ debug => sub { set_debug },
+) or Usage 'Invalid parameter';
+
+# Announce ourselves
+verbose "$FindBin::Script v$VERSION";
+
+$clearadm = Clearadm->new;
+
+my %opts = Vars;
+
+my $title = 'Alerts';
+
+heading $title;
+
+unless ($opts{'delete.x'} or $opts{'edit.x'} or $opts{action}) {
+ displayError 'Action not defined!';
+ exit 1;
+} # unless
+
+unless ($opts{action} eq 'Add') {
+ unless ($opts{name}) {
+ displayError 'Alert not defined!';
+ exit 1;
+ } # unless
+} # unless
+
+my ($err, $msg);
+
+if ($opts{action} eq 'Add') {
+ display h1 {class => 'center'}, 'Add Alert';
+ editAlert;
+} elsif ($opts{'delete.x'}) {
+ ($err, $msg) = $clearadm->DeleteAlert ($opts{name});
+
+ if ($msg !~ /Records deleted/) {
+ displayError "Unable to delete alert $opts{name}\n$msg";
+ } else {
+ display h1 {class => 'center'}, $title;
+ display h3 {class => 'center'}, "Alert '$opts{name}' deleted";
+
+ displayAlert;
+ } # if
+} elsif ($opts{'edit.x'}) {
+ display h1 {class => 'center'}, 'Edit Alert: ', $opts{name};
+ editAlert ($opts{name});
+} elsif ($opts{action} eq 'Post') {
+ delete $opts{action};
+
+ my %system = $clearadm->GetAlert ($opts{name});
+
+ if (%system or $opts{oldname}) {
+ my $name = delete $opts{oldname};
+
+ $name ||= $opts{name};
+
+ ($err, $msg) = $clearadm->UpdateAlert ($name, %opts);
+
+ if ($err) {
+ displayError "$msg (Status: $err)";
+ } else {
+ display h1 {class => 'center'}, $title;
+ display h3 {class => 'center'}, "Alert '$opts{name}' updated";
+
+ displayAlert;
+ } # if
+ } else {
+ ($err, $msg) = $clearadm->AddAlert (%opts);
+
+ if ($err) {
+ displayError "$msg (Status: $err)";
+ } else {
+
+ display h1 {class => 'center'}, $title;
+ display h3 {class => 'center'}, "Alert '$opts{name}' added";
+
+ displayAlert;
+ } # if
+ } # if
+} else {
+ displayError "Unknown action - $opts{action}";
+} # if
+
+footing;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<CGI>
+
+L<CGI::Carp|CGI::Carp>
+
+L<FindBin>
+
+L<Getopt::Long|Getopt::Long>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ Clearadm
+ ClearadmWeb
+ Display
+ Utils
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/Clearadm.pm">Clearadm</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/ClearadmWeb.pm">ClearadmWeb</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Utils.pm">Utils</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this script
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2010, ClearSCM, Inc. All rights reserved.
+
+=cut
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: processfilesystem.cgi,v $
+
+Delete a filesystem
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.4 $
+
+=item Created:
+
+Mon Oct 25 11:10:47 PDT 2008
+
+=item Modified:
+
+$Date: 2011/02/14 14:52:40 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage processfileystem.cgi: [-u|sage] [-ve|rbose] [-d|ebug]
+ action=[edit|delete]
+ system=<system> filesystem=<filesystem>
+
+ Where:
+ -u|sage: Displays usage
+ -ve|rbose: Be verbose
+ -d|ebug: Output debug messages
+
+ action: "edit" or "delete" to edit or delete the filesystem
+ system: System
+ filesystem: Filesystem to delete
+
+=head2 DESCRIPTION
+
+This script edits or deletes a filessystem from Clearadm
+
+=cut
+
+use strict;
+use warnings;
+
+use FindBin;
+use Getopt::Long;
+use CGI qw (:standard :cgi-lib *table start_Tr end_Tr);
+use CGI::Carp 'fatalsToBrowser';
+
+use lib "$FindBin::Bin/lib", "$FindBin::Bin/../lib";
+
+use Clearadm;
+use ClearadmWeb;
+use Display;
+use Utils;
+
+my $VERSION = '$Revision: 1.4 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+my $clearadm;
+
+# Main
+GetOptions (
+ usage => sub { Usage },
+ verbose => sub { set_verbose },
+ debug => sub { set_debug },
+) or Usage 'Invalid parameter';
+
+# Announce ourselves
+verbose "$FindBin::Script v$VERSION";
+
+$clearadm = Clearadm->new;
+
+my %opts = Vars;
+
+my $title = 'Process Filesystem: '
+ . ucfirst $opts{system}
+ . ":$opts{filesystem}";
+
+heading $title;
+
+unless ($opts{'delete.x'} or $opts{'edit.x'} or $opts{action}) {
+ displayError 'Action not defined!';
+ footing;
+ exit 1;
+} # unless
+
+unless ($opts{system}) {
+ displayError 'System not defined!';
+ footing;
+ exit 1;
+} # unless
+
+unless ($opts{filesystem}) {
+ displayError 'System not defined!';
+ footing;
+ exit 1;
+} # unless
+
+my ($err, $msg);
+
+if ($opts{'delete.x'}) {
+ ($err, $msg) = $clearadm->DeleteFilesystem ($opts{system}, $opts{filesystem});
+
+ if ($msg !~ /Records deleted/) {
+ displayError "Unable to delete $opts{system}:$opts{filesystem}\n$msg";
+ } else {
+ display h1 {
+ class => 'center'
+ }, 'Filesystem ' . ucfirst $opts{system} . ":$opts{filesystem} deleted";
+ } # if
+} elsif ($opts{'edit.x'}) {
+ display h1 {
+ class => 'center'
+ }, 'Edit Filesystem: ', ucfirst $opts{system} . ":$opts{filesystem}";
+
+ editFilesystem ($opts{system}, $opts{filesystem});
+} elsif ($opts{action} eq 'Post') {
+ delete $opts{action};
+ delete $opts{'edit.x'}
+ if $opts{'edit.x'};
+ delete $opts{'edit.y'}
+ if $opts{'edit.y'};
+
+ ($err, $msg) = $clearadm->UpdateFilesystem (
+ $opts{system},
+ $opts{filesystem},
+ %opts
+ );
+
+ if ($err) {
+ displayError "$msg (Status: $err)";
+ } else {
+ display h1 {class => 'center'}, ucfirst $opts{system} . ":$opts{filesystem} updated";
+
+ displayFilesystem ($opts{system});
+ } # if
+} else {
+ displayError "Unknown action - $opts{action}";
+} # if
+
+footing;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<CGI>
+
+L<CGI::Carp|CGI::Carp>
+
+L<FindBin>
+
+L<Getopt::Long|Getopt::Long>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ Clearadm
+ ClearadmWeb
+ Display
+ Utils
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/Clearadm.pm">Clearadm</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/ClearadmWeb.pm">ClearadmWeb</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Utils.pm">Utils</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this script
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2010, ClearSCM, Inc. All rights reserved.
+
+=cut
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: processnotification.cgi,v $
+
+Process a notification
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.3 $
+
+=item Created:
+
+Mon Oct 25 11:10:47 PDT 2008
+
+=item Modified:
+
+$Date: 2011/02/14 14:53:07 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage processnotification.cgi: [-u|sage] [-ve|rbose] [-d|ebug]
+ action=[Add|Delete|Edit|Post]
+ notification=<notificationname>
+
+ Where:
+ -u|sage: Displays usage
+ -ve|rbose: Be verbose
+ -d|ebug: Output debug messages
+
+ action: Specifies to add, delete, edit or post an alert
+ notification: Name of notification to delete or edit
+
+=head2 DESCRIPTION
+
+This script adds, deletes, edits or posts a notification
+
+=cut
+
+use strict;
+use warnings;
+
+use FindBin;
+use Getopt::Long;
+use CGI qw (:standard :cgi-lib *table start_Tr end_Tr);
+use CGI::Carp 'fatalsToBrowser';
+
+use lib "$FindBin::Bin/lib", "$FindBin::Bin/../lib";
+
+use Clearadm;
+use ClearadmWeb;
+use Display;
+use Utils;
+
+my $VERSION = '$Revision: 1.3 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+my $clearadm;
+
+# Main
+GetOptions (
+ usage => sub { Usage },
+ verbose => sub { set_verbose },
+ debug => sub { set_debug },
+) or Usage 'Invalid parameter';
+
+# Announce ourselves
+verbose "$FindBin::Script v$VERSION";
+
+$clearadm = Clearadm->new;
+
+my %opts = Vars;
+
+my $title = 'Notifications';
+
+heading $title;
+
+unless ($opts{'delete.x'} or $opts{'edit.x'} or $opts{action}) {
+ displayError 'Action not defined!';
+ exit 1;
+} # unless
+
+unless ($opts{action} eq 'Add') {
+ unless ($opts{name}) {
+ displayError 'Notification not defined!';
+ exit 1;
+ } # unless
+} # unless
+
+my ($err, $msg);
+
+if ($opts{action} eq 'Add') {
+ display h1 {class => 'center'}, 'Add Notification';
+ editNotification;
+} elsif ($opts{'delete.x'}) {
+ ($err, $msg) = $clearadm->DeleteNotification ($opts{name});
+
+ if ($msg !~ /Records deleted/) {
+ displayError "Unable to delete notification $opts{name}\n$msg";
+ } else {
+ display h1 {class => 'center'}, $title;
+ display h3 {class => 'center'}, "Notification '$opts{name}' deleted";
+
+ displayNotification;
+ } # if
+} elsif ($opts{'edit.x'}) {
+ display h1 {class => 'center'}, 'Edit Notification: ', $opts{name};
+ editNotification ($opts{name});
+} elsif ($opts{action} eq 'Post') {
+ delete $opts{action};
+
+ my %notification = $clearadm->GetNotification ($opts{name});
+
+ # System and Filesystem are links to tables of the same name. If specified
+ # they need to match up to an existing system or they can be null. If we
+ # have this as an edited field and the user puts nothing in them then we
+ # get '', which won't work. So change '' -> undef.
+
+ # TODO: Should think about making these dropdowns instead (However that would
+ # require AJAX to update filesystem when system changes). For now let's do
+ # this.
+# $opts{system} = undef
+# if $opts{system} eq '';
+# $opts{filesystem} = undef
+# if $opts{filesystem} eq '';
+
+ if (%notification or $opts{oldname}) {
+ my $name = delete $opts{oldname};
+
+ $name ||= $opts{name};
+
+ ($err, $msg) = $clearadm->UpdateNotification ($name, %opts);
+
+ if ($err) {
+ displayError "$msg (Status: $err)";
+ } else {
+ display h1 {class => 'center'}, $title;
+ display h3 {class => 'center'}, "Notification '$opts{name}' updated";
+
+ displayNotification;
+ } # if
+ } else {
+ ($err, $msg) = $clearadm->AddNotification (%opts);
+
+ if ($err) {
+ displayError "$msg (Status: $err)";
+ } else {
+
+ display h1 {class => 'center'}, $title;
+ display h3 {class => 'center'}, "Notification '$opts{name}' added";
+
+ displayNotification;
+ } # if
+ } # if
+} else {
+ displayError "Unknown action - $opts{action}";
+} # if
+
+footing;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<CGI>
+
+L<CGI::Carp|CGI::Carp>
+
+L<FindBin>
+
+L<Getopt::Long|Getopt::Long>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ Clearadm
+ ClearadmWeb
+ Display
+ Utils
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/Clearadm.pm">Clearadm</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/ClearadmWeb.pm">ClearadmWeb</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Utils.pm">Utils</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this script
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2010, ClearSCM, Inc. All rights reserved.
+
+=cut
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: processrunning.pl,v $
+
+Checks to see if a process is running
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.2 $
+
+=item Created:
+
+Mon Dec 13 09:13:27 EST 2010
+
+=item Modified:
+
+$Date: 2013/05/21 16:42:17 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage processrunning.pl: [-u|sage] [-ve|rbose] [-deb|ug]
+ -name <processname>
+
+ Where:
+ -u|sage: Displays usage
+
+ -ve|rbose: Be verbose
+ -deb|ug: Output debug messages
+
+ -name: Name of the process to check for.
+
+=head1 DESCRIPTION
+
+This script will simply check to see if the process specified is running. Note
+that it uses ps(1) and relies on the presence of Cygwin when run on Windows
+systems.
+
+=cut
+
+use strict;
+use warnings;
+
+use FindBin;
+use Getopt::Long;
+
+use lib "$FindBin::Bin/lib", "$FindBin::Bin/../lib";
+
+use Display;
+use OSDep;
+use Utils;
+
+my $VERSION = '$Revision: 1.2 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+sub restart ($) {\r
+ my ($restart) = @_;
+
+ my ($status, @output) = Execute "$restart 2>&1";
+
+ unless ($status) {
+ display "Successfully executed restart option: $restart";
+
+ display $_ foreach (@output);
+ } else {
+ display "Unable to restart process using $restart (Status: $status)";
+
+ display $_ foreach (@output);
+ } # unless
+
+ return $status;
+} # restart
+
+# Main
+error "Cannot use $FindBin::Script when using Windows - hint try using Cgywin", 1
+ if $ARCH eq 'windows';
+
+my ($name, $restart);
+
+GetOptions (
+ usage => sub { Usage },
+ verbose => sub { set_verbose },
+ debug => sub { set_debug },
+ 'name=s' => \$name,
+ 'restart=s' => \$restart,
+) or Usage "Invalid parameter";
+
+Usage 'Extraneous options: ' . join ' ', @ARGV
+ if @ARGV;
+
+Usage "Must specify process name"
+ unless $name;
+
+# Announce ourselves
+verbose "$FindBin::Script V$VERSION";
+
+my $opts = $ARCH eq 'cygwin' ? '-eWf' : '-ef';
+
+my $cmd = "ps $opts | grep -i '$name' | grep -v \"grep -i \'$name\'\"";
+
+my ($status, @output) = Execute $cmd;
+
+unless ($status) {
+ display "No process found with the name of $name";
+
+ $status = restart $restart if $restart;
+
+ exit $status;
+} elsif ($status == 2) {
+ error "Unable to execute $cmd (Status: $status) - $!\n"
+ . join ("\n", @output), $status;
+} # if
+
+foreach (@output) {
+ next
+ if /grep -i '$name'/;
+
+ next
+ if /grep -i $name/;
+
+ next
+ if /$FindBin::Script/;
+
+ display "Found processes named $name";
+ exit 0;
+} # foreach
+
+display "Did not find any processes named $name";
+
+exit restart $restart if $restart;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<FindBin>
+
+L<Getopt::Long|Getopt::Long>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ Display
+ Utils
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Utils.pm">Utils</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this script
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2010, ClearSCM, Inc. All rights reserved.
+
+=cut
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: processschedule.cgi,v $
+
+Process a schedule
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.3 $
+
+=item Created:
+
+Mon Oct 25 11:10:47 PDT 2008
+
+=item Modified:
+
+$Date: 2011/02/14 14:53:36 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage processschedule.cgi: [-u|sage] [-ve|rbose] [-d|ebug]
+ action=[Add|Delete|Edit|Post]
+ schedule=<schedule>
+
+ Where:
+ -u|sage: Displays usage
+ -ve|rbose: Be verbose
+ -d|ebug: Output debug messages
+
+ action: Specifies to add, delete, edit or post an alert
+ schedule: Schedule to delete or edit
+
+=head2 DESCRIPTION
+
+This script adds, deletes, edits or posts a schedule
+
+=cut
+
+use strict;
+use warnings;
+
+use FindBin;
+use Getopt::Long;
+use CGI qw (:standard :cgi-lib *table start_Tr end_Tr);
+use CGI::Carp 'fatalsToBrowser';
+
+use lib "$FindBin::Bin/lib", "$FindBin::Bin/../lib";
+
+use Clearadm;
+use ClearadmWeb;
+use Display;
+use Utils;
+
+my $VERSION = '$Revision: 1.3 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+my $clearadm;
+
+# Main
+GetOptions (
+ usage => sub { Usage },
+ verbose => sub { set_verbose },
+ debug => sub { set_debug },
+) or Usage 'Invalid parameter';
+
+# Announce ourselves
+verbose "$FindBin::Script v$VERSION";
+
+$clearadm = Clearadm->new;
+
+my %opts = Vars;
+
+my $title = 'Schedule';
+
+heading $title;
+
+unless ($opts{'delete.x'} or $opts{'edit.x'} or $opts{action}) {
+ displayError 'Action not defined!';
+ exit 1;
+} # unless
+
+unless ($opts{action} eq 'Add') {
+ unless ($opts{name}) {
+ displayError 'Schedule not defined!';
+ exit 1;
+ } # unless
+} # unless
+
+my ($err, $msg);
+
+if ($opts{action} eq 'Add') {
+ display h1 {class => 'center'}, 'Add Schedule';
+ editSchedule;
+} elsif ($opts{'delete.x'}) {
+ ($err, $msg) = $clearadm->DeleteSchedule ($opts{name});
+
+ if ($msg !~ /Records deleted/) {
+ displayError "Unable to delete schedule $opts{name}\n$msg";
+ } else {
+ display h1 {class => 'center'}, $title;
+ display h3 {class => 'center'}, "Schedule $opts{name} deleted";
+
+ displaySchedule;
+ } # if
+} elsif ($opts{'edit.x'}) {
+ display h1 {class => 'center'}, 'Edit Schedule: ', $opts{name};
+ editSchedule ($opts{name});
+} elsif ($opts{action} eq 'Post') {
+ delete $opts{action};
+
+ my $nbr = delete $opts{nbr};
+ my $multiplier = delete $opts{multiplier};
+
+ if ($nbr == 1) {
+ $multiplier = substr $multiplier, 0, -1;
+ } # if
+
+ $opts{frequency} = "$nbr $multiplier";
+
+ my %schedule = $clearadm->GetSchedule ($opts{name});
+
+ if (%schedule or $opts{oldname}) {
+ my $name = delete $opts{oldname};
+
+ $name ||= $opts{name};
+
+ $opts{active} = 'false'
+ unless $opts{active};
+
+ ($err, $msg) = $clearadm->UpdateSchedule ($name, %opts);
+
+ if ($err) {
+ displayError "$msg (Status: $err)";
+ } else {
+ display h1 {class => 'center'}, $title;
+ display h3 {class => 'center'}, "Schedule $opts{name} updated";
+
+ displaySchedule;
+ } # if
+ } else {
+ ($err, $msg) = $clearadm->AddSchedule (%opts);
+
+ if ($err) {
+ displayError "$msg (Status: $err)";
+ } else {
+
+ display h1 {class => 'center'}, $title;
+ display h3 {class => 'center'}, "Schedule $opts{name} added";
+
+ displaySchedule;
+ } # if
+ } # if
+} else {
+ displayError "Unknown action - $opts{action}";
+} # if
+
+footing;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<CGI>
+
+L<CGI::Carp|CGI::Carp>
+
+L<FindBin>
+
+L<Getopt::Long|Getopt::Long>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ Clearadm
+ ClearadmWeb
+ Display
+ Utils
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/Clearadm.pm">Clearadm</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/ClearadmWeb.pm">ClearadmWeb</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Utils.pm">Utils</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this script
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2010, ClearSCM, Inc. All rights reserved.
+
+=cut
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: processsystem.cgi,v $
+
+Process a system
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.6 $
+
+=item Created:
+
+Mon Oct 25 11:10:47 PDT 2008
+
+=item Modified:
+
+$Date: 2011/02/14 14:53:51 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage processsystem.cgi: [-u|sage] [-ve|rbose] [-d|ebug]
+ action=[Add|Delete|Edit|Post] system=<systemname>
+
+
+ Where:
+ -u|sage: Displays usage
+ -ve|rbose: Be verbose
+ -d|ebug: Output debug messages
+
+ action: Specifies to add, delete, edit or post an alert
+ system: Name of alert to delete or edit
+
+=head2 DESCRIPTION
+
+This script adds, deletes, edits or posts an alert
+
+=cut
+
+use strict;
+use warnings;
+
+use FindBin;
+use Getopt::Long;
+use CGI qw (:standard :cgi-lib *table start_Tr end_Tr);
+use CGI::Carp 'fatalsToBrowser';
+
+use lib "$FindBin::Bin/lib", "$FindBin::Bin/../lib";
+
+use Clearadm;
+use ClearadmWeb;
+use Display;
+use Utils;
+
+my $VERSION = '$Revision: 1.6 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+my $clearadm;
+
+# Main
+GetOptions (
+ usage => sub { Usage },
+ verbose => sub { set_verbose },
+ debug => sub { set_debug },
+) or Usage 'Invalid parameter';
+
+# Announce ourselves
+verbose "$FindBin::Script v$VERSION";
+
+$clearadm = Clearadm->new;
+
+my %opts = Vars;
+
+my $title = 'Process System';
+
+heading $title;
+
+unless ($opts{'delete.x'} or $opts{'edit.x'} or $opts{action} eq 'Post') {
+ displayError 'Action not defined!';
+ exit 1;
+} # unless
+
+unless ($opts{action} eq 'Add') {
+ unless ($opts{name}) {
+ displayError 'System not defined!';
+ exit 1;
+ } # unless
+} # unless
+
+my ($err, $msg);
+
+if ($opts{action} eq 'Add') {
+ display h1 {class => 'center'}, 'Add System';
+ editSystem;
+} elsif ($opts{'delete.x'}) {
+ ($err, $msg) = $clearadm->DeleteSystem ($opts{name});
+
+ display h1 { class => 'center'}, ucfirst $opts{name} . ' deleted';
+} elsif ($opts{'edit.x'}) {
+ display h1 {class => 'center'}, 'Edit System: ', ucfirst $opts{name};
+ editSystem ($opts{name});
+} elsif ($opts{action} eq 'Post') {
+ delete $opts{action};
+
+ my %system = $clearadm->GetSystem ($opts{name});
+
+ $opts{active} = 'false'
+ unless $opts{active};
+
+ if (%system) {
+ ($err, $msg) = $clearadm->UpdateSystem ($opts{name}, %opts);
+
+ if ($err) {
+ displayError "$msg (Status: $err)";
+ } else {
+ display h1 {class => 'center'}, ucfirst $opts{name} . ' updated';
+
+ displaySystem ($opts{name});
+ } # if
+ } else {
+ ($err, $msg) = $clearadm->AddSystem (%opts);
+
+ if ($err) {
+ displayError "$msg (Status: $err)";
+ } else {
+ display h1 {class => 'center'}, ucfirst $opts{name} . ' updated';
+
+ displaySystem ($opts{name});
+ } # if
+ } # if
+} else {
+ displayError "Unknown action - $opts{action}";
+} # if
+
+footing;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<CGI>
+
+L<CGI::Carp|CGI::Carp>
+
+L<FindBin>
+
+L<Getopt::Long|Getopt::Long>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ Clearadm
+ ClearadmWeb
+ Display
+ Utils
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/Clearadm.pm">Clearadm</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/ClearadmWeb.pm">ClearadmWeb</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Utils.pm">Utils</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this script
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2010, ClearSCM, Inc. All rights reserved.
+
+=cut
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: processtask.cgi,v $
+
+Process a task
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.2 $
+
+=item Created:
+
+Mon Oct 25 11:10:47 PDT 2008
+
+=item Modified:
+
+$Date: 2011/04/09 05:38:26 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage processtask.cgi: [-u|sage] [-ve|rbose] [-d|ebug]
+ action=[Add|Delete|Edit|Post]
+ task=<task>
+
+ Where:
+ -u|sage: Displays usage
+ -ve|rbose: Be verbose
+ -d|ebug: Output debug messages
+
+ action: Specifies to add, delete, edit or post an alert
+ task: Task to delete or edit
+
+=head2 DESCRIPTION
+
+This script adds, deletes, edits or posts a schedule
+
+=cut
+
+use strict;
+use warnings;
+
+use FindBin;
+use Getopt::Long;
+use CGI qw (:standard :cgi-lib *table start_Tr end_Tr);
+use CGI::Carp 'fatalsToBrowser';
+
+use lib "$FindBin::Bin/lib", "$FindBin::Bin/../lib";
+
+use Clearadm;
+use ClearadmWeb;
+use Display;
+use Utils;
+
+my $VERSION = '$Revision: 1.2 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+my $clearadm;
+
+# Main
+GetOptions (
+ usage => sub { Usage },
+ verbose => sub { set_verbose },
+ debug => sub { set_debug },
+) or Usage 'Invalid parameter';
+
+# Announce ourselves
+verbose "$FindBin::Script v$VERSION";
+
+$clearadm = Clearadm->new;
+
+my %opts = Vars;
+
+my $title = 'Tasks';
+
+heading $title;
+
+unless ($opts{'delete.x'} or $opts{'edit.x'} or $opts{action}) {
+ displayError 'Action not defined!';
+ exit 1;
+} # unless
+
+unless ($opts{action} eq 'Add') {
+ unless ($opts{name}) {
+ displayError 'Task not defined!';
+ exit 1;
+ } # unless
+} # unless
+
+my ($err, $msg);
+
+if ($opts{action} eq 'Add') {
+ display h1 {class => 'center'}, 'Add Task';
+ editTask;
+} elsif ($opts{'delete.x'}) {
+ ($err, $msg) = $clearadm->DeleteTask ($opts{name});
+
+ if ($msg !~ /Records deleted/) {
+ displayError "Unable to delete task $opts{name}\n$msg";
+ } else {
+ display h1 {class => 'center'}, $title;
+ display h3 {class => 'center'}, "Task $opts{name} deleted";
+
+ displayTask;
+ } # if
+} elsif ($opts{'edit.x'}) {
+ display h1 {class => 'center'}, 'Edit Task: ', $opts{name};
+ editTask ($opts{name});
+} elsif ($opts{action} eq 'Post') {
+ delete $opts{action};
+
+ my %task = $clearadm->GetTask ($opts{name});
+
+ if (%task or $opts{oldname}) {
+ my $name = delete $opts{oldname};
+
+ $name ||= $opts{name};
+
+ ($err, $msg) = $clearadm->UpdateTask ($name, %opts);
+
+ if ($err) {
+ displayError "$msg (Status: $err)";
+ } else {
+ display h1 {class => 'center'}, $title;
+ display h3 {class => 'center'}, "Task $opts{name} updated";
+
+ displayTask;
+ } # if
+ } else {
+ ($err, $msg) = $clearadm->AddTask (%opts);
+
+ if ($err) {
+ displayError "$msg (Status: $err)";
+ } else {
+
+ display h1 {class => 'center'}, $title;
+ display h3 {class => 'center'}, "Task $opts{name} added";
+
+ displayTask;
+ } # if
+ } # if
+} else {
+ displayError "Unknown action - $opts{action}";
+} # if
+
+footing;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<CGI>
+
+L<CGI::Carp|CGI::Carp>
+
+L<FindBin>
+
+L<Getopt::Long|Getopt::Long>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ Clearadm
+ ClearadmWeb
+ Display
+ Utils
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/Clearadm.pm">Clearadm</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/ClearadmWeb.pm">ClearadmWeb</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Utils.pm">Utils</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this script
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2010, ClearSCM, Inc. All rights reserved.
+
+=cut
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: readme.cgi,v $
+
+Display the README file
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.2 $
+
+=item Created:
+
+Mon Oct 25 11:10:47 PDT 2008
+
+=item Modified:
+
+$Date: 2011/02/14 14:54:19 $
+
+=back
+
+=head1 DESCRIPTION
+
+This script displays the README file
+
+=cut
+
+use strict;
+use warnings;
+
+use FindBin;
+use Getopt::Long;
+
+use CGI qw (:standard *table start_Tr end_Tr);
+use CGI::Carp 'fatalsToBrowser';
+
+use lib "$FindBin::Bin/lib", "$FindBin::Bin/../lib";
+
+use ClearadmWeb;
+use Display;
+use Utils;
+
+# Main
+GetOptions (
+ 'usage' => sub { Usage },
+ 'verbose' => sub { set_verbose },
+ 'debug' => sub { set_debug },
+) or Usage "Invalid parameter";
+
+# Announce ourselves
+verbose "$ClearadmWeb::APPNAME V$ClearadmWeb::VERSION";
+
+heading;
+
+display '<pre><blockquote>';
+
+display h1 {class => 'center'}, "$ClearadmWeb::APPNAME: README";
+
+display $_
+ foreach (ReadFile 'README');
+
+display '</pre></blockquote>';
+
+footing;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<CGI|CGI.html>
+
+L<CGI::Carp|CGI::Carp>
+
+L<FindBin>
+
+L<Getopt::Long|Getopt::Long>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ Display
+ Utils
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/ClearadmWeb.pm">ClearadmWeb</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Utils.pm">Utils</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this script
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2010, ClearSCM, Inc. All rights reserved.
+
+=cut
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: runlog.cgi,v $
+
+Display the run log
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.11 $
+
+=item Created:
+
+Mon Oct 25 11:10:47 PDT 2008
+
+=item Modified:
+
+$Date: 2011/06/02 06:10:02 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage runlog.cgi: [-u|sage] [-ve|rbose] [-d|ebug]
+
+ Where:
+ -u|sage: Displays usage
+ -ve|rbose: Be verbose
+ -d|ebug: Output debug messages
+
+=head2 DESCRIPTION
+
+This script displays the run log
+
+=cut
+
+use strict;
+use warnings;
+
+use FindBin;
+use Getopt::Long;
+use CGI qw (:standard :cgi-lib *table start_Tr end_Tr);
+use CGI::Carp 'fatalsToBrowser';
+
+use lib "$FindBin::Bin/lib", "$FindBin::Bin/../lib";
+
+use Clearadm;
+use ClearadmWeb;
+use Display;
+use Utils;
+
+my $VERSION = '$Revision: 1.11 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+my $clearadm;
+
+my %opts = Vars;
+
+$opts{start} ||= 0;
+$opts{page} ||= 10;
+
+# Main
+GetOptions (
+ usage => sub { Usage },
+ verbose => sub { set_verbose },
+ debug => sub { set_debug },
+) or Usage 'Invalid parameter';
+
+# Announce ourselves
+verbose "$FindBin::Script v$VERSION";
+
+$clearadm = Clearadm->new;
+
+my $title = 'Run Log';
+
+heading $title;
+
+undef $opts{task}
+ if $opts{task} and $opts{task} eq 'All';
+
+$opts{system} ||= 'All';
+
+undef $opts{status}
+ if $opts{status} and $opts{status} eq 'All';
+
+display h1 {class => 'center'}, $title;
+
+displayRunlog (%opts);
+
+footing;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<CGI>
+
+L<CGI::Carp|CGI::Carp>
+
+L<FindBin>
+
+L<Getopt::Long|Getopt::Long>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ Clearadm
+ ClearadmWeb
+ Display
+ Utils
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/Clearadm.pm">Clearadm</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/ClearadmWeb.pm">ClearadmWeb</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Utils.pm">Utils</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this script
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2010, ClearSCM, Inc. All rights reserved.
+
+=cut
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: schedule.cgi,v $
+
+Display schedule
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.2 $
+
+=item Created:
+
+Mon Oct 25 11:10:47 PDT 2008
+
+=item Modified:
+
+$Date: 2011/02/14 14:54:32 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage schedule.cgi: [-u|sage] [-ve|rbose] [-d|ebug]
+
+ Where:
+ -u|sage: Displays usage
+ -ve|rbose: Be verbose
+ -d|ebug: Output debug messages
+
+=head2 DESCRIPTION
+
+This script displays schedule
+
+=cut
+
+use strict;
+use warnings;
+
+use FindBin;
+use Getopt::Long;
+use CGI qw (:standard :cgi-lib *table start_Tr end_Tr);
+use CGI::Carp 'fatalsToBrowser';
+
+use lib "$FindBin::Bin/lib", "$FindBin::Bin/../lib";
+
+use Clearadm;
+use ClearadmWeb;
+use Display;
+use Utils;
+
+my $VERSION = '$Revision: 1.2 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+my $clearadm;
+
+# Main
+GetOptions (
+ usage => sub { Usage },
+ verbose => sub { set_verbose },
+ debug => sub { set_debug },
+) or Usage 'Invalid parameter';
+
+# Announce ourselves
+verbose "$FindBin::Script v$VERSION";
+
+$clearadm = Clearadm->new;
+
+my $title = 'Schedule';
+
+heading $title;
+
+display h1 {class => 'center'}, $title;
+
+displaySchedule;
+
+footing;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<CGI>
+
+L<CGI::Carp|CGI::Carp>
+
+L<FindBin>
+
+L<Getopt::Long|Getopt::Long>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ Clearadm
+ ClearadmWeb
+ Display
+ Utils
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/Clearadm.pm">Clearadm</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/ClearadmWeb.pm">ClearadmWeb</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Utils.pm">Utils</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this script
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2010, ClearSCM, Inc. All rights reserved.
+
+=cut
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: setup.pl,v $
+
+Setup Clearadm
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.1 $
+
+=item Created:
+
+Mon Dec 13 09:13:27 EST 2010
+
+=item Modified:
+
+$Date: 2011/01/09 18:12:05 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage setup.pl: [-u|sage] [-ve|rbose] [-deb|ug]
+ [-package [all|agent|database|tasks|web]]
+
+ Where:
+ -u|sage: Displays usage
+
+ -ve|rbose: Be verbose
+ -deb|ug: Output debug messages
+
+ -package: Which subpackage to set up (Default: all).
+
+=head1 DESCRIPTION
+
+This script will setup Clearadm packages on machines. You must be root
+(or administrator on Windows) to setup packages. Setting up web package
+configures the web server. Setting up the tasks portion sets up cleartasks
+poriton. Cleartasks periodically runs the predefined and user defined
+tasks and should only be set up on one machine. The agent package sets up
+clearagent.pl. This should be run on all machines that you intend to monitor.
+The database package sets up the Clearadm database.
+
+Default, sets up all packages on the current machine.
+
+=cut
+
+use strict;
+use warnings;
+
+use Socket;
+
+use FindBin;
+use Getopt::Long;
+
+use lib "$FindBin::Bin/lib", "$FindBin::Bin/../lib";
+
+use Clearadm;
+use Display;
+use OSDep;
+use Utils;
+
+my $VERSION = '$Revision: 1.1 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+sub SetupAgent () {
+ verbose 'Setting up Agent...';
+
+ my ($status, @output, $cmd);
+
+ if ($ARCH eq 'cygwin') {
+ verbose '[Cygwin] Creating up Clearagent Service';
+
+ $cmd = 'cygrunsrv -I clearagent -p C:/Cygwin/bin/perl ';
+ $cmd .= '> -a "/opt/clearscm/clearadm/clearagent.pl -nodaemon"';
+
+ ($status, @output) = Execute "$cmd 2>&1";
+
+ error "Unable to execute $cmd (Status: $status)\n" . join ("\n", @output), 1
+ if $status;
+
+ verbose '[Cygwin] Starting Clearagent Service';
+
+ $cmd .= 'net start clearagent';
+ ($status, @output) = Execute "$cmd 2>&1";
+
+ error "Unable to execute $cmd (Status: $status)\n" . join ("\n", @output), 1
+ if $status;
+ } else {
+ my $Arch = ucfirst $ARCH;
+
+ verbose 'Creating clearagent user';
+
+ $cmd = 'useradd -Mr clearagent';
+
+ ($status, @output) = Execute "$cmd 2>&1";
+
+ if ($status == 9) {
+ warning "The user clearagent already exists";
+ } elsif ($status != 0) {
+ error "Unable to execute $cmd (Status: $status)\n" . join ("\n", @output), 1;
+ } # if
+
+ verbose 'Setting permissions on log and var directories';
+
+ $cmd = "chmod 777 $Clearadm::CLEAROPTS{CLEARADM_BASE}/var;";
+ $cmd .= "chmod 777 $Clearadm::CLEAROPTS{CLEARADM_BASE}/var/run;";
+ $cmd .= "chmod 777 $Clearadm::CLEAROPTS{CLEARADM_BASE}/log";
+
+ ($status, @output) = Execute "$cmd 2>&1";
+
+ error "Unable to execute $cmd (Status: $status)\n" . join ("\n", @output), 1
+ if $status;
+
+ verbose "[$Arch] Setting up clearagent daemon";
+
+ # Symlink $CLEARADM/etc/conf.d/clearadm -> /etc/init.d
+ my $confdir = '/etc/init.d';
+
+ error "Cannot find conf.d directory ($confdir)", 1
+ unless -d $confdir;
+
+ unless (-e "$confdir/clearadm") {
+ $cmd = "ln -s $FindBin::Bin/etc/init.d/clearadm $confdir";
+
+ ($status, @output) = Execute "$cmd 2>&1";
+
+ error "Unable to execute $cmd (Status: $status)\n" . join ("\n", @output), 1
+ if $status;
+ } # unless
+
+ # Setup runlevel links
+ $cmd = 'update-rc.d clearagent defaults';
+
+ ($status, @output) = Execute "$cmd 2>&1";
+
+ error "Unable to execute $cmd (Status: $status)\n" . join ("\n", @output), 1
+ if $status;
+
+ verbose 'Starting clearagent';
+
+ $cmd = 'service clearagent start';
+
+ error "Unable to execute $cmd (Status: $status)\n" . join ("\n", @output), 1
+ if $status;
+ } # if
+
+ verbose "Done";
+
+ return;
+} # SetupAgent
+
+sub SetupTasks () {
+ my ($status, @output, $cmd);
+
+ verbose 'Setting up Tasks...';
+
+ # Symlink $CLEARADM/etc/conf.d/cleartasks -> /etc/init.d
+ my $confdir = '/etc/init.d';
+
+ error "Cannot find conf.d directory ($confdir)", 1
+ unless -d $confdir;
+
+ unless (-e "$confdir/clearadm") {
+ $cmd = "ln -s $FindBin::Bin/etc/init.d/cleartasks $confdir";
+
+ ($status, @output) = Execute "$cmd 2>&1";
+
+ error "Unable to execute $cmd (Status: $status)\n" . join ("\n", @output), 1
+ if $status;
+ } # unless
+
+ # Setup runlevel links
+ $cmd = 'update-rc.d cleartasks defaults';
+
+ ($status, @output) = Execute "$cmd 2>&1";
+
+ error "Unable to execute $cmd (Status: $status)\n" . join ("\n", @output), 1
+ if $status;
+
+ verbose 'Starting cleartasks';
+
+ $cmd = 'service cleartasks start';
+
+ ($status, @output) = Execute "$cmd 2>&1";
+
+ error "Unable to execute $cmd (Status: $status)\n" . join ("\n", @output), 1
+ if $status;
+
+ verbose 'Done';
+
+ return;
+} # SetupTasks
+
+sub SetupWeb () {
+ verbose 'Setting up Web...';
+
+ my ($status, @output, $cmd);
+
+ # Symlink $CLEARADM/etc/conf.d/clearadm -> /etc/apache2/conf.d
+ my $confdir = '/etc/apache2/conf.d';
+
+ error "Cannot find Apache 2 conf.d directory ($confdir)", 1
+ unless -d $confdir;
+
+ unless (-e "$confdir/clearadm") {
+ $cmd = "ln -s $FindBin::Bin/etc/conf.d/clearadm $confdir";
+
+ ($status, @output) = Execute "$cmd 2>&1";
+
+ error "Unable to execute $cmd (Status: $status)\n" . join ("\n", @output), 1
+ if $status;
+ } # unless
+
+ if ($ARCH eq 'cygwin') {
+ $cmd = 'net stop apache2; net start apache2';
+ } else {
+ $cmd = '/etc/init.d/apache2 restart';
+ } # if
+
+ ($status, @output) = Execute "$cmd 2>&1";
+
+ error "Unable to execute $cmd (Status: $status)\n" . join ("\n", @output), 1
+ if $status;
+
+ verbose 'Done';
+
+ return;
+} # SetupWeb
+
+sub SetupDatabase () {
+ verbose 'Setting up Database';
+
+ my ($status, @output, $cmd);
+
+ # TODO: Probably need to use -u root -p and prompt for MySQL root user's
+ # password.
+ $cmd = "mysql < $Clearadm::CLEAROPTS{CLEARADM_BASE}/etc/clearadm.sql";
+
+ ($status, @output) = Execute "$cmd 2>&1";
+
+ error "Unable to execute $cmd (Status: $status)\n" . join ("\n", @output), 1
+ if $status;
+
+ verbose 'Setting up database users';
+
+ $cmd = "mysql clearadm < $Clearadm::CLEAROPTS{CLEARADM_BASE}/etc/users.sql";
+
+ ($status, @output) = Execute "$cmd 2>&1";
+
+ error "Unable to execute $cmd (Status: $status)\n" . join ("\n", @output), 1
+ if $status;
+
+ verbose 'Setting up predefined tasks';
+
+ $cmd = "mysql clearadm < $Clearadm::CLEAROPTS{CLEARADM_BASE}/etc/load.sql";
+
+ ($status, @output) = Execute "$cmd 2>&1";
+
+ error "Unable to execute $cmd (Status: $status)\n" . join ("\n", @output), 1
+ if $status;
+
+ verbose 'Done';
+
+ return;
+} # SetupDatbase
+
+# Main
+error "Cannot setup Clearadm when using Windows - hint try using Cgywin", 1
+ if $ARCH eq 'windows';
+
+Usage 'You must be root'
+ unless $> == 0 or $ARCH eq 'cygwin';
+
+my $package = 'all';
+
+GetOptions (
+ usage => sub { Usage },
+ verbose => sub { set_verbose },
+ debug => sub { set_debug },
+ 'package=s' => \$package,
+) or Usage "Invalid parameter";
+
+Usage 'Extraneous options: ' . join ' ', @ARGV
+ if @ARGV;
+
+# Announce ourselves
+verbose "$FindBin::Script V$VERSION";
+
+my @validPackages = (
+ 'all',
+ 'agent',
+ 'database',
+ 'tasks',
+ 'web',
+);
+
+my $lcpackage = lc $package;
+
+unless (InArray $lcpackage, @validPackages) {
+ Usage "Invalid -package $package";
+} # unless
+
+if ($lcpackage eq 'all') {
+ SetupAgent;
+ SetupDatabase;
+ SetupTasks;
+ SetupWeb;
+} elsif ($lcpackage eq 'agent') {
+ SetupAgent;
+} elsif ($lcpackage eq 'database') {
+ SetupDatabase;
+} elsif ($lcpackage eq 'tasks') {
+ SetupTasks;
+} elsif ($lcpackage eq 'agent') {
+ SetupWeb;
+} # if
+
+=pod
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: systemdetails.cgi,v $
+
+System Details
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.22 $
+
+=item Created:
+
+Mon Oct 25 11:10:47 PDT 2008
+
+=item Modified:
+
+$Date: 2011/01/28 21:31:25 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage systemdetails.cgi: [-u|sage] [-ve|rbose] [-d|ebug]
+ -s|ystem <systemname>
+
+
+ Where:
+ -u|sage: Displays usage
+ -ve|rbose: Be verbose
+ -d|ebug: Output debug messages
+
+ -s|ystem <systemname>: Name of system to display details for
+
+=head2 DESCRIPTION
+
+This script displays the details for the given system
+
+=cut
+
+use strict;
+use warnings;
+
+use FindBin;
+use Getopt::Long;
+use CGI qw (:standard :cgi-lib *table start_Tr end_Tr);
+use CGI::Carp 'fatalsToBrowser';
+
+use lib "$FindBin::Bin/lib", "$FindBin::Bin/../lib";
+
+use Clearadm;
+use ClearadmWeb;
+use Clearcase::Server;
+use Display;
+use Utils;
+
+my $VERSION = '$Revision: 1.22 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+my $name = param ('system');
+
+my $subtitle = 'System Details';
+
+my $clearadm;
+
+sub DisplayTable ($) {
+ my ($server) = @_;
+
+ my $unknown = font {-class => 'unknown'}, 'Unknown';
+
+ # Data fields
+ my $systemName = setField ($server->name);
+ my $ccVer = setField ($server->ccVer);
+ my $osVer = setField ($server->osVer);
+ my $hardware = setField ($server->hardware);
+ my $licenseHost = setField ($server->licenseHost);
+ my $registryHost = setField ($server->registryHost);
+ my $registryRegion = setField ($server->registryRegion);
+ my $mvfsBlocksPerDirectory = setField ($server->mvfsBlocksPerDirectory);
+ my $mvfsCleartextMnodes = setField ($server->mvfsCleartextMnodes);
+ my $mvfsDirectoryNames = setField ($server->mvfsDirectoryNames);
+ my $mvfsFileNames = setField ($server->mvfsFileNames);
+ my $mvfsFreeMnodes = setField ($server->mvfsFreeMnodes);
+ my $mvfsInitialMnodeTableSize = setField ($server->mvfsInitialMnodeTableSize);
+ my $mvfsMinCleartextMnodes = setField ($server->mvgsMinCleartextMnodes);
+ my $mvfsMinFreeMnodes = setField ($server->mvfsMinFreeMnodes);
+ my $mvfsNamesNotFound = setField ($server->mvfsNamesNotFound);
+ my $mvfsRPCHandles = setField ($server->mvfsRPCHandles);
+ my $interopRegion = setField ($server->interopRegion);
+ my $scalingFactor = setField ($server->scalingFactor);
+ my $cleartextIdleLifetime = setField ($server->cleartextIdleLifetime);
+ my $vobHashTableSize = setField ($server->vobHashTableSize);
+ my $cleartextHashTableSize = setField ($server->cleartextHashTableSize);
+ my $dncHashTableSize = setField ($server->dncHashTableSize);
+ my $threadHashTableSize = setField ($server->threadHashTableSize);
+ my $processHashTableSize = setField ($server->processHashTableSize);
+
+ display h2 {class => 'center'}, 'Clearcase Information';
+
+ display start_table {cellspacing => 1, class => 'main'};
+
+ display start_Tr;
+ display th {class => 'label'}, 'Name:';
+ display td {class => 'data', colspan => 4}, $systemName;
+ display th {class => 'label'}, 'Registry Host:';
+ display td {class => 'data', colspan => 4},
+ a {href => "systemdetails.cgi?server=$registryHost"}, $registryHost;
+ display end_Tr;
+
+ display start_Tr;
+ display th {class => 'label'}, 'Registry Region:';
+ display td {class => 'data', -colspan => 4}, $registryRegion;
+ display th {class => 'label'}, 'License Host:';
+ display td {class => 'data', colspan => 4},
+ a {-href => "systemdetails.cgi?server=$licenseHost"}, $licenseHost;
+ display end_Tr;
+
+ display start_Tr;
+ display th {class => 'label'}, 'Clearcase Version:';
+ display td {class => 'data', colspan => 4}, $ccVer;
+ display th {class => 'label'}, 'OS Version:';
+ display td {class => 'data', colspan => 4}, $osVer;
+ display end_Tr;
+
+ display start_Tr;
+ display th {class => 'label'}, 'Interop Region:';
+ display td {class => 'dataRight'}, $interopRegion;
+ display th {class => 'label'}, 'Scaling Factor:';
+ display td {class => 'dataRight'}, $scalingFactor;
+ display th {class => 'label'}, 'Clrtxt Idle Lifetime:';
+ display td {class => 'dataRight'}, $cleartextIdleLifetime;
+ display th {class => 'label'}, 'VOB Hash:';
+ display td {class => 'dataRight', -colspan => 3}, $vobHashTableSize;
+ display end_Tr;
+
+ display start_Tr;
+ display th {class => 'label'}, 'Clrtxt Hash:';
+ display td {class => 'dataRight'}, $cleartextHashTableSize;
+ display th {class => 'label'}, 'DNC Hash:';
+ display td {class => 'dataRight'}, $dncHashTableSize;
+ display th {class => 'label'}, 'Thread Hash:';
+ display td {class => 'dataRight'}, $threadHashTableSize;
+ display th {class => 'label'}, 'Process Hash:';
+ display td {class => 'dataRight', colspan => 3}, $processHashTableSize;
+ display end_Tr;
+
+ display start_Tr;
+ display th {class => 'labelCentered', -colspan => 10}, 'MVFS Parameters';
+ display end_Tr;
+
+ display start_Tr;
+ display th {class => 'label'}, 'Blocks/Dir:';
+ display td {class => 'dataRight'}, $mvfsBlocksPerDirectory;
+ display th {class => 'label'}, 'Clrtxt Mnodes:';
+ display td {class => 'dataRight'}, $mvfsCleartextMnodes;
+ display th {class => 'label'}, 'DirNames:';
+ display td {class => 'dataRight'}, $mvfsDirectoryNames;
+ display th {class => 'label'}, 'FileNames:';
+ display td {class => 'dataRight'}, $mvfsFileNames;
+ display th {class => 'label'}, 'Free Mnodes:';
+ display td {class => 'dataRight'}, $mvfsFreeMnodes;
+ display end_Tr;
+
+ display start_Tr;
+ display th {class => 'label'}, 'Init Mnodes:';
+ display td {class => 'dataRight'}, $mvfsInitialMnodeTableSize;
+ display th {class => 'label'}, 'Min Clrtxt Mnodes:';
+ display td {class => 'dataRight'}, $mvfsMinCleartextMnodes;
+ display th {class => 'label'}, 'Min Free Mnodes:';
+ display td {class => 'dataRight'}, $mvfsMinFreeMnodes;
+ display th {class => 'label'}, 'Names Not Found:';
+ display td {class => 'dataRight'}, $mvfsNamesNotFound;
+ display th {class => 'label'}, 'RPC Handles:';
+ display td {class => 'dataRight'}, $mvfsRPCHandles;
+ display end_Tr;
+
+ display end_table;
+
+ return;
+} # DisplayTable
+
+# Main
+GetOptions (
+ usage => sub { Usage },
+ verbose => sub { set_verbose },
+ debug => sub { set_debug },
+ 'server=s' => \$name,
+) or Usage 'Invalid parameter';
+
+# Announce ourselves
+verbose "$FindBin::Script v$VERSION";
+
+my $title = $subtitle;
+ $title .= $name ? ": $name" : '';
+
+$clearadm = Clearadm->new;
+
+$subtitle = h1 {class => 'center'}, 'System Details: ' . ucfirst $name;
+
+heading $title;
+
+unless ($name) {
+ display 'System is required';
+ exit;
+}
+
+display h1 {class => 'center'}, $subtitle;
+
+displaySystem $name;
+
+#my $server = new Clearcase::Server ($name);
+
+#DisplayTable $server;
+
+footing;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<CGI>
+
+L<CGI::Carp|CGI::Carp>
+
+L<FindBin>
+
+L<Getopt::Long|Getopt::Long>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ Clearadm
+ ClearadmWeb
+ Clearcase::Server
+ Display
+ Utils
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/Clearadm.pm">Clearadm</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/ClearadmWeb.pm">ClearadmWeb</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Clearcase/Server.pm">Clearcase::Server</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Utils.pm">Utils</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this script
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2010, ClearSCM, Inc. All rights reserved.
+
+=cut
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: systems.cgi,v $
+
+Systems
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.15 $
+
+=item Created:
+
+Mon Oct 25 11:10:47 PDT 2008
+
+=item Modified:
+
+$Date: 2011/02/14 14:54:59 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage systems.cgi: [-u|sage] [-ve|rbose] [-d|ebug]
+
+ Where:
+ -u|sage: Displays usage
+ -v|erbose: Be verbose
+ -d|ebug: Output debug messages
+
+=head2 DESCRIPTION
+
+This script displays all known systems
+
+=cut
+
+use strict;
+use warnings;
+
+use FindBin;
+use Getopt::Long;
+use CGI qw (:standard :cgi-lib *table start_Tr end_Tr start_td end_td);
+use CGI::Carp 'fatalsToBrowser';
+
+use lib "$FindBin::Bin/lib", "$FindBin::Bin/../lib";
+
+use Clearadm;
+use ClearadmWeb;
+use Display;
+use Utils;
+
+my $VERSION = '$Revision: 1.15 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+my $subtitle = 'Systems Status: All Systems';
+
+my $clearadm;
+
+sub DisplaySystems () {
+ display start_table {cellspacing => 1, class => 'main'};
+
+ display start_Tr;
+ display th {class => 'labelCentered'}, 'Action';
+ display th {class => 'labelCentered'}, 'Name';
+ display th {class => 'labelCentered'}, 'Alias';
+ display th {class => 'labelCentered'}, 'Admin';
+ display th {class => 'labelCentered'}, 'Type';
+ display th {class => 'labelCentered'}, 'Last Contacted';
+ display th {class => 'labelCentered'}, 'Current load';
+ display th {class => 'labelCentered'}, 'Threshold';
+ display th {class => 'labelCentered'}, 'Load Avg';
+ display end_Tr;
+
+ foreach ($clearadm->FindSystem) {
+ my %system = %{$_};
+
+ $system{alias} = setField $system{alias}, 'N/A';
+ $system{region} = setField $system{region}, 'N/A';
+
+ my $admin = ($system{email})
+ ? a {href => "mailto:$system{email}"}, $system{admin}
+ : $system{admin};
+
+ my $alias = ($system{alias} !~ 'N/A')
+ ? a {
+ href => "systemdetails.cgi?system=$system{name}"
+ }, $system{alias}
+ : $system{alias};
+
+ my %load = $clearadm->GetLatestLoadavg ($system{name});
+
+ $load{loadavg} ||= 0;
+ $load{timestamp} ||= 'unknown';
+
+ my $class = $load{loadavg} < $system{loadavgThreshold}
+ ? 'data'
+ : 'dataAlert';
+ my $classRight = $load{loadavg} < $system{loadavgThreshold}
+ ? 'dataRight'
+ : 'dataRightAlert';
+ my $classRightTop = $load{loadavg} < $system{loadavgThreshold}
+ ? 'dataRightTop'
+ : 'dataRightAlertTop';
+
+ display start_Tr;
+ display start_td {class => 'data'};
+
+ my $areYouSure = 'Are you sure you want to delete this system?\n'
+ . 'Doing so will remove all records related to '
+ . $system{name}
+ . '\nincluding filesystem records and history as well as '
+ . 'loadavg history.';
+
+ display start_form {
+ method => 'post',
+ action => "processsystem.cgi",
+ };
+
+ display input {
+ name => 'name',
+ type => 'hidden',
+ value => $system{name},
+ };
+
+ display input {
+ name => 'delete',
+ type => 'image',
+ src => 'delete.png',
+ alt => 'Delete',
+ title => 'Delete',
+ value => 'Delete',
+ onclick => "return AreYouSure ('$areYouSure');"
+ };
+ display input {
+ name => 'edit',
+ type => 'image',
+ src => 'edit.png',
+ alt => 'Edit',
+ title => 'Edit',
+ value => 'Edit',
+ };
+ display checkbox {
+ disabled => 'disabled',
+ checked => $system{active} eq 'true' ? 1 : 0,
+ };
+
+ if ($system{notification}) {
+ display a {href => "alertlog.cgi?system=$system{name}"}, img {
+ src => 'alert.png',
+ border => 0,
+ alt => 'Alert!',
+ title => 'This system has alerts',
+ };
+ } # if
+
+ display end_form;
+
+ display end_td;
+ display td {class => $class},
+ a {href => "systemdetails.cgi?system=$system{name}"}, $system{name};
+ display td {class => $class}, $alias;
+ display td {class => $class}, $admin;
+ display td {class => $class}, $system{type};
+
+ my $lastheardfromClass = 'dataCentered';
+ my $lastheardfromData = $system{lastheardfrom};
+
+ unless ($clearadm->SystemAlive (%system)) {
+ $lastheardfromClass = 'dataCenteredAlert';
+ $lastheardfromData = a {
+ href => "alertlog.cgi?system=$system{name}",
+ class => 'alert',
+ title => "Have not heard from $system{name} for a while"
+ }, $system{lastheardfrom};
+ $system{notification} = 'Heartbeat';
+ } # unless
+
+ display td {class => $lastheardfromClass}, "$lastheardfromData ",
+ font {class => 'dim' }, "<br>Up: $load{uptime}";
+ display td {class => $classRightTop}, "$load{loadavg} ",
+ font {class => 'dim' }, "<br>$load{timestamp}";
+ display td {class => $classRightTop}, $system{loadavgThreshold};
+ display td {class => $class},
+ a {
+ href =>
+ "plot.cgi?type=loadavg&system=$system{name}&scaling=Hour&points=24"
+ }, img {
+ src => "plotloadavg.cgi?system=$system{name}&tiny=1",
+ border => 0,
+ };
+ display end_Tr;
+ } # foreach
+
+ display end_table;
+
+ display p {class => 'center'}, a {
+ href => 'processsystem.cgi?action=Add',
+ }, 'New system', img {
+ src => 'add.png',
+ border => 0,
+ };
+
+ return;
+} # DisplaySystems
+
+# Main
+GetOptions (
+ usage => sub { Usage },
+ verbose => sub { set_verbose },
+ debug => sub { set_debug },
+) or Usage 'Invalid parameter';
+
+# Announce ourselves
+verbose "$FindBin::Script v$VERSION";
+
+$clearadm = Clearadm->new;
+
+heading $subtitle;
+
+display h1 {class => 'center'}, $subtitle;
+
+DisplaySystems;
+
+footing;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<CGI>
+
+L<CGI::Carp|CGI::Carp>
+
+L<FindBin>
+
+L<Getopt::Long|Getopt::Long>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ Clearadm
+ ClearadmWeb
+ Display
+ Utils
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/Clearadm.pm">Clearadm</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/ClearadmWeb.pm">ClearadmWeb</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Utils.pm">Utils</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this script
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2010, ClearSCM, Inc. All rights reserved.
+
+=cut
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: tasks.cgi,v $
+
+Display tasks
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.3 $
+
+=item Created:
+
+Mon Oct 25 11:10:47 PDT 2008
+
+=item Modified:
+
+$Date: 2011/01/27 01:15:13 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage tasks.cgi: [-u|sage] [-ve|rbose] [-d|ebug]
+
+ Where:
+ -u|sage: Displays usage
+ -ve|rbose: Be verbose
+ -d|ebug: Output debug messages
+
+=head2 DESCRIPTION
+
+This script displays tasks
+
+=cut
+
+use strict;
+use warnings;
+
+use FindBin;
+use Getopt::Long;
+use CGI qw (:standard :cgi-lib *table start_Tr end_Tr);
+use CGI::Carp 'fatalsToBrowser';
+
+use lib "$FindBin::Bin/lib", "$FindBin::Bin/../lib";
+
+use Clearadm;
+use ClearadmWeb;
+use Display;
+use Utils;
+
+my $VERSION = '$Revision: 1.3 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+my $clearadm;
+
+my %opts = Vars;
+
+# Main
+GetOptions (
+ usage => sub { Usage },
+ verbose => sub { set_verbose },
+ debug => sub { set_debug },
+) or Usage 'Invalid parameter';
+
+verbose "$FindBin::Script v$VERSION";
+
+$clearadm = Clearadm->new;
+
+my $title = $opts{task}
+ ? "Tasks matching $opts{task}"
+ : 'Tasks';
+
+heading $title;
+
+display h1 {class => 'center'}, $title;
+
+displayTask ($opts{task});
+
+footing;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<CGI>
+
+L<CGI::Carp|CGI::Carp>
+
+L<FindBin>
+
+L<Getopt::Long|Getopt::Long>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ Clearadm
+ ClearadmWeb
+ Display
+ Utils
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/Clearadm.pm">Clearadm</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/ClearadmWeb.pm">ClearadmWeb</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Utils.pm">Utils</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this script
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2010, ClearSCM, Inc. All rights reserved.
+
+=cut
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl
+use strict;
+use warnings;
+
+use FindBin;
+use Getopt::Long;
+
+use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
+
+use Clearadm;
+use Display;
+use Utils;
+
+my $clearadm = new Clearadm;
+
+my %system = (
+ name => 'jupiter',
+ alias => 'defaria.com',
+ admin => 'Andrew DeFaria',
+ os => 'Linux defaria.com 2.6.32-25-generic-pae #45-Ubuntu SMP Sat Oct 16 21:01:33 UTC 2010 i686 GNU/Linux',
+ type => 'Linux',
+ description => 'Home server',
+);
+
+my %package = (
+ 'system' => 'jupiter',
+ 'name' => 'MySQL',
+ 'version' => '5.1',
+);
+
+my %update;
+
+my %filesystem = (
+ 'system' => 'jupiter',
+ 'filesystem' => '/dev/mapper/jupiter-root',
+ 'fstype' => 'ext3',
+ 'mount' => '/',
+ 'threshold' => 90,
+);
+
+my %vob = (
+ 'system' => 'jupiter',
+ 'tag' => '/vobs/clearscm',
+);
+
+my %view = (
+ 'system' => 'jupiter',
+ 'tag' => 'andrew_view',
+);
+
+GetOptions (
+ 'verbose' => sub { set_verbose },
+ 'usage' => sub { Usage },
+);
+
+sub DisplayRecord (%) {
+ my (%record) = @_;
+
+ foreach (keys %record) {
+ if ($record{$_}) {
+ display "$_: $record{$_}";
+ } else {
+ display "$_: <undef>";
+ } # if
+ } # foreach
+} # DisplayRecord
+
+sub DisplayRecords (@) {
+ my (@records) = @_;
+
+ DisplayRecord %{$_}
+ foreach (@records);
+} # DisplayRecords
+
+sub TestSystem () {
+ verbose "Adding system $system{name}";
+
+ my ($err, $msg) = $clearadm->AddSystem (%system);
+
+ if ($err == 1062) {
+ warning 'You already have that record!';
+ } elsif ($err) {
+ error $msg, $err;
+ } # if
+
+ verbose "Finding systems that match \'jup\'";
+ DisplayRecords $clearadm->FindSystem ('jup');
+
+ verbose "Getting record for \'jupiter\'";
+ DisplayRecord $clearadm->GetSystem ('jupiter');
+
+ verbose "Finding systems that match \'def\'";
+ DisplayRecords $clearadm->FindSystem ('def');
+
+ verbose "Getting record for \'defaria.com\'";
+ DisplayRecord $clearadm->GetSystem ('defaria.com');
+
+ %update = (
+ 'region' => 'East Coast',
+ );
+
+ verbose "Updating system $system{name}";
+
+ ($err, $msg) = $clearadm->UpdateSystem ($system{name}, %update);
+
+ error $msg, $err
+ if $err;
+} # TestaSystem
+
+sub TestPackage () {
+ verbose "Adding package $package{name}";
+
+ my ($err, $msg) = $clearadm->AddPackage (%package);
+
+ if ($err == 1062) {
+ warning 'You already have that record!';
+ } elsif ($err) {
+ error $msg, $err;
+ } # if
+
+ %update = (
+ 'vendor' => 'ClearSCM',
+ 'description' => 'This is not ClearSCM\'s version of MySQL',
+ );
+
+ verbose "Updating package $package{name}";
+
+ ($err, $msg) = $clearadm->UpdatePackage ($package{system}, $package{name}, %update);
+
+ error $msg, $err
+ if $err;
+
+ verbose "Finding packages for $system{name} that match \'My\'";
+ DisplayRecords $clearadm->FindPackage ($system{name}, 'My');
+
+ verbose ("Getting package for $system{name} record for \'MySQL\'");
+ DisplayRecord $clearadm->GetPackage ($system{name}, 'MySQL');
+} # TestPackage
+
+sub TestFilesystem () {
+ verbose "Adding filesystem $filesystem{filesystem}";
+
+ my ($err, $msg) = $clearadm->AddFilesystem (%filesystem);
+
+ error $msg, $err
+ if $err;
+
+ $filesystem{filesystem} = '/dev/sda5';
+ $filesystem{path} = '/disk2';
+
+ verbose "Adding filesystem $filesystem{filesystem}";
+
+ ($err, $msg) = $clearadm->AddFilesystem (%filesystem);
+
+ error $msg, $err
+ if $err;
+
+ %update = (
+ 'filesystem' => '/dev/sdb5',
+ );
+
+ verbose "Updating filesystem $filesystem{filesystem}";
+
+ ($err, $msg) = $clearadm->UpdateFilesystem (
+ $filesystem{system}, $filesystem{filesystem}, %update
+ );
+
+ error $msg, $err
+ if $err;
+
+ verbose "Finding filesystems for $system{name} that match \'My\'";
+ DisplayRecords $clearadm->FindFilesystem ($system{name}, 'root');
+
+ verbose ("Getting filesystem for $system{name} record for \'/dev/sdb5\'");
+ DisplayRecord $clearadm->GetFilesystem ($system{name}, '/dev/sdb5');
+} # TestFilesystem
+
+sub TestVob () {
+ verbose "Adding vob $vob{tag}";
+
+ my ($err, $msg) = $clearadm->AddVob (%vob);
+
+ error $msg, $err
+ if $err;
+
+ $vob{tag} = '/vobs/clearscm_old';
+
+ verbose "Adding vob $vob{tag}";
+
+ ($err, $msg) = $clearadm->AddVob (%vob);
+
+ error $msg, $err
+ if $err;
+
+ verbose "Finding vobs that match \'clearscm\'";
+ DisplayRecords $clearadm->FindVob ('clearscm');
+
+ verbose ("Getting vob for \'clearscm\'");
+ DisplayRecord $clearadm->GetVob ('clearscm');
+} # TestVob
+
+sub TestView () {
+ verbose "Adding view $view{tag}";
+
+ my ($err, $msg) = $clearadm->AddView (%view);
+
+ error $msg, $err
+ if $err;
+
+ $view{tag} = 'andrew2_view';
+
+ verbose "Adding view $view{tag}";
+
+ ($err, $msg) = $clearadm->AddView (%view);
+
+ error $msg, $err
+ if $err;
+
+ verbose "Finding views that match \'andrew\'";
+ DisplayRecords $clearadm->FindView ('andrew');
+
+ verbose ("Getting view for \'view\'");
+ DisplayRecord $clearadm->GetView ('andrew');
+} # TestView
+
+TestSystem;
+TestPackage;
+TestFilesystem;
+TestVob;
+TestView;
+
+########################
+verbose "Deleting system $system{name}";
+
+my ($err, $msg) = $clearadm->DeleteSystem ($system{name});
+
+error $msg, $err
+ if $err;
+
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: updatefs.pl,v $
+
+Update Filesystem
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.29 $
+
+=item Created:
+
+Mon Dec 13 09:13:27 EST 2010
+
+=item Modified:
+
+$Date: 2011/06/16 15:12:50 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage updatefs.pl: [-u|sage] [-ve|rbose] [-deb|ug]
+ [-host [<host>|all]] [-fs [<fs>|all]]
+
+ Where:
+ -u|sage: Displays usage
+
+ -ve|rbose: Be verbose
+ -deb|ug: Output debug messages
+
+ -host [<host>|all]: Update host or all hosts (Default: all)
+ -fs [<fs>|all]: Update filesystem or all (Default: all)
+
+=head1 DESCRIPTION
+
+This script will record the state of a filesystem.
+
+=cut
+
+use strict;
+use warnings;
+
+use Net::Domain qw(hostname);
+use FindBin;
+use Getopt::Long;
+
+use lib "$FindBin::Bin/lib", "$FindBin::Bin/../lib";
+
+use Clearadm;
+use Clearexec;
+use DateUtils;
+use Display;
+use Utils;
+
+my $VERSION = '$Revision: 1.29 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+my $clearadm = Clearadm->new;
+my $clearexec = Clearexec->new;
+
+my ($host, $fs);
+
+# Given a host and a filesystem, formulate a fs record
+sub snapshotFS ($$) {
+ my ($systemRef, $filesystem) = @_;
+
+ my %system = %{$systemRef};
+
+ my %filesystem = $clearadm->GetFilesystem ($system{name}, $filesystem);
+
+ unless (%filesystem) {
+ error "Filesystem $host:$filesystem not in clearadm database - try adding it";
+
+ return;
+ } # unless
+
+ my %fs = (
+ system => $system{name},
+ filesystem => $filesystem,
+ timestamp => Today2SQLDatetime,
+ );
+
+ # Sun is so braindead!
+ # TODO: Verify this works under Solaris
+ if ($system{type} eq 'Unix') {
+ foreach ('ufs', 'vxfs') {
+ my $cmd = "/usr/bin/df -k -F $filesystem{mount}";
+
+ my ($status, @unixfs) = $clearexec->execute ($cmd);
+
+ if ($status != 0) {
+ error ('Unable to determine fsinfo for '
+ . "$system{name}:$filesystem{mount} ($cmd)\n" .
+ join "\n", @unixfs
+ );
+
+ return;
+ } # if
+
+ # Skip heading
+ shift @unixfs;
+
+ for (my $i = 0; $i < scalar @unixfs; $i++) {
+ my $firstField;
+
+ # Trim leading and trailing spaces
+ $unixfs[$i] =~ s/^\s+//;
+ $unixfs[$i] =~ s/\s+$//;
+
+ my @fields = split /\s+/, $unixfs[$i];
+
+ if (@fields == 1) {
+ $firstField = 0;
+ $i++;
+
+ @fields = split /\s+/, $unixfs[$i];;
+ } else {
+ $firstField = 1;
+ } #if
+
+ $fs{size} = $fields[$firstField] * 1024;
+ $fs{used} = $fields[$firstField + 1] * 1024;
+ $fs{free} = $fields[$firstField + 2] * 1024;
+ $fs{reserve} = $fs{size} - $fs{used} - $fs{free};
+ } # for
+ } # foreach
+ } elsif ($system{type} eq 'Linux' or $system{type} eq 'Windows') {
+ my $cmd = "/bin/df --block-size=1 -P $filesystem{mount}";
+
+ my ($status, @linuxfs) = $clearexec->execute ($cmd);
+
+ if ($status != 0) {
+ error ("Unable to determine fsinfo for $system{name}:$filesystem{mount}\n"
+ . join "\n", @linuxfs
+ );
+
+ return;
+ } # if
+
+ # Skip heading
+ shift @linuxfs;
+
+ $_ = shift @linuxfs;
+ my @fields = split;
+
+ $fs{size} = $fields[1];
+ $fs{used} = $fields[2];
+ $fs{free} = $fields[3];
+ $fs{mount} = $fields[5];
+ $fs{reserve} = $fs{size} - $fs{used} - $fs{free};
+ } # if
+
+ return %fs;
+} # snapshotFS
+
+# Main
+GetOptions (
+ 'usage' => sub { Usage },
+ 'verbose' => sub { set_verbose },
+ 'debug' => sub { set_debug },
+ 'host=s' => \$host,
+ 'fs=s' => \$fs,
+) or Usage "Invalid parameter";
+
+Usage 'Extraneous options: ' . join ' ', @ARGV
+ if @ARGV;
+
+# Announce ourselves
+verbose "$FindBin::Script V$VERSION";
+
+my $exit = 0;
+
+foreach my $system ($clearadm->FindSystem ($host)) {
+ next if $$system{active} eq 'false';
+
+ my $status = $clearexec->connectToServer (
+ $$system{name},
+ $$system{port}
+ );
+
+ unless ($status) {
+ verbose "Unable to connect to system $$system{name}:$$system{port}";
+ next;
+ } # unless
+
+ foreach my $filesystem ($clearadm->FindFilesystem ($$system{name}, $fs)) {
+ verbose "Snapshotting $$system{name}:$$filesystem{filesystem}";
+
+ my %fs = snapshotFS ($system, $$filesystem{filesystem});
+
+ if (%fs) {
+ my ($err, $msg) = $clearadm->AddFS (%fs);
+
+ error $msg, $err if $err;
+ } # if
+
+ # Check if over threshold
+ my %notification = $clearadm->GetNotification ('Filesystem');
+
+ next
+ unless %notification;
+
+ my $usedPct = sprintf (
+ '%.2f',
+ (($fs{used} + $fs{reserve}) / $fs{size}) * 100
+ );
+
+ if ($usedPct >= $$filesystem{threshold}) {
+ $exit = 2;
+ display YMDHMS . " System: $$filesystem{system} "
+ . "Filesystem: $$filesystem{filesystem} Used: $usedPct% "
+ . "Threshold: $$filesystem{threshold}";
+ } else {
+ $clearadm->ClearNotifications ($$system{name}, $$filesystem{filesystem});
+ } # if
+ } # foreach
+
+ $clearexec->disconnectFromServer;
+} # foreach
+
+exit $exit;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<FindBin>
+
+L<Getopt::Long|Getopt::Long>
+
+L<Net::Domain|Net::Domain>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ Clearadm
+ Clearexec
+ DateUtils
+ Display
+ Utils
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/Clearadm.pm">Clearadm</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/Clearexec.pm">Clearexec</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/DateUtils.pm">DateUtils</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Utils.pm">Utils</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this script
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2010, ClearSCM, Inc. All rights reserved.
+
+=cut
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: updatela.pl,v $
+
+Update Load Average
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.29 $
+
+=item Created:
+
+Mon Dec 13 09:13:27 EST 2010
+
+=item Modified:
+
+$Date: 2011/06/16 15:14:52 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage updatela.pl: [-u|sage] [-ve|rbose] [-deb|ug]
+ [-host [<host>|all]]
+
+ Where:
+ -u|sage: Displays usage
+
+ -ve|rbose: Be verbose
+ -deb|ug: Output debug messages
+
+ -host [<host>|all]: Update host or all hosts (Default: all)
+ -fs [<fs>|all]: Update filesystem or all (Default: all)
+
+=head1 DESCRIPTION
+
+This script will record the load average of a system
+
+=cut
+
+use strict;
+use warnings;
+
+use Net::Domain qw(hostname);
+use FindBin;
+use Getopt::Long;
+
+use lib "$FindBin::Bin/lib", "$FindBin::Bin/../lib";
+
+use Clearadm;
+use Clearexec;
+use DateUtils;
+use Display;
+use Utils;
+
+my $VERSION = '$Revision: 1.29 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+my $clearadm = Clearadm->new;
+my $clearexec = Clearexec->new;
+
+my $host;
+
+# Given a host, formulate a loadavg record
+sub snapshotLoad ($) {
+ my ($systemRef) = @_;
+
+ my %system = %{$systemRef};
+
+ my ($status, @output);
+
+ $status = $clearexec->connectToServer (
+ $system{name}, $system{port}
+ );
+
+ error "Unable to connect to system $system{name}:$system{port}", 1
+ unless $status;
+
+ verbose "Snapshotting load on $system{name}";
+
+ my %load = (
+ system => $system{name},
+ );
+
+ my $cmd = 'uptime';
+
+ ($status, @output) = $clearexec->execute ($cmd);
+
+ return
+ if $status;
+
+ # Parsing uptime is odd. Sometimes we get output like
+ #
+ # 10:11:59 up 17 days, 22:11, 6 users, load average: 1.08, 1.10, 1.10
+ #
+ # And sometimes we get output like:
+ #
+ # 10:11:15 up 23:04, 0 users, load average: 0.00, 0.00, 0.00
+ #
+ # Notice that if the machine was up for less than a day you don't get the
+ # "x days" portion of output. There is no real controls on uptime to format
+ # the output better, so we parse for either format.
+ if ($output[0] =~ /up\s+(.+?),\s+(.+?),\s+(\d+) user.*load average:\s+(.+?),/) {
+ $load{uptime} = "$1 $2";
+ $load{users} = $3;
+ $load{loadavg} = "$4";
+ } elsif ($output[0] =~ /up\s+(.+?),\s+(\d+) user.*load average:\s+(.+?),/) {
+ $load{uptime} = "$1";
+ $load{users} = $2;
+ $load{loadavg} = "$3";
+ } else {
+ warning "Unable to parse output of uptime from $system{name}";
+ return;
+ } # if
+
+ # On Windows sytems, Cygwin's uptime does not return a loadavg at all - it
+ # returns only 0! So we have load.vbs which give us the LoadPercentage
+ if ($system{type} =~ /windows/i) {
+ my $loadvbs = 'c:/cygwin/opt/clearscm/clearadm/load.vbs';
+ $cmd = "cscript /nologo $loadvbs";
+
+ ($status, @output) = $clearexec->execute ($cmd);
+
+ chop @output if $output[0] =~ /\r/;
+
+ return
+ if $status;
+
+ $load{loadavg} = $output[0] / 100;
+ } # if
+
+ $clearexec->disconnectFromServer;
+
+ return %load;
+} # snapshotLoad
+
+# Main
+GetOptions (
+ 'usage' => sub { Usage },
+ 'verbose' => sub { set_verbose },
+ 'debug' => sub { set_debug },
+ 'host=s' => \$host,
+) or Usage "Invalid parameter";
+
+Usage 'Extraneous options: ' . join ' ', @ARGV
+ if @ARGV;
+
+# Announce ourselves
+verbose "$FindBin::Script V$VERSION";
+
+my $exit = 0;
+
+foreach my $system ($clearadm->FindSystem ($host)) {
+ next if $$system{active} eq 'false';
+
+ my %load = snapshotLoad $system;
+
+ if (%load) {
+ my ($err, $msg) = $clearadm->AddLoadavg (%load);
+
+ error $msg, $err if $err;
+ } else {
+ error "Unable to get loadavg for system $$system{name}", 1;
+ } # if
+
+ # Check if over threshold
+ my %notification = $clearadm->GetNotification ('Loadavg');
+
+ next
+ unless %notification;
+
+ if ($load{loadavg} >= $$system{loadavgThreshold}) {
+ $exit = 2;
+ error YMDHMS . " System: $$system{name} "
+ . "Loadavg $load{loadavg} "
+ . "Threshold $$system{loadavgThreshold}";
+ } else {
+ $clearadm->ClearNotifications ($$system{name});
+ } # if
+} # foreach
+
+exit $exit;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<FindBin>
+
+L<Getopt::Long|Getopt::Long>
+
+L<Net::Domain|Net::Domain>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ Clearadm
+ Clearexec
+ DateUtils
+ Display
+ Utils
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/Clearadm.pm">Clearadm</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/Clearexec.pm">Clearexec</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/DateUtils.pm">DateUtils</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Utils.pm">Utils</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this script
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2010, ClearSCM, Inc. All rights reserved.
+
+=cut
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: updatesystem.pl,v $
+
+Update System
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.17 $
+
+=item Created:
+
+Mon Dec 13 09:13:27 EST 2010
+
+=item Modified:
+
+$Date: 2012/11/09 06:44:38 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage updatesystem.pl: [-u|sage] [-ve|rbose] [-deb|ug]
+ [-del|ete -h|ost <host>]
+
+ Where:
+ -u|sage: Displays usage
+
+ -ve|rbose: Be verbose
+ -deb|ug: Output debug messages
+
+ -del|ete: Delete host
+ -h|ost <host>: Host to operate on (Default: Current host)
+ -p|ort <port>: Clearexec port to connect to
+
+=head1 DESCRIPTION
+
+This script will add/update the system to the Clearadm database. You can also
+delete a system from the Clearadm database.
+
+=cut
+
+use strict;
+use warnings;
+
+use Sys::Hostname;
+
+use FindBin;
+use Getopt::Long;
+
+use lib "$FindBin::Bin/lib", "$FindBin::Bin/../lib";
+
+use Clearadm;
+use Clearexec;
+use Display;
+use Utils;
+
+my $VERSION = '$Revision: 1.17 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+my $clearadm = Clearadm->new;
+my $clearexec = Clearexec->new;
+
+my ($delete, $host, $port);
+
+sub GetFilesystems (%) {
+ my (%system) = @_;
+
+ # TODO: Unix/Linux systems often vary as to what parameters df supports. The
+ # -P is to intended to make this POSIX standard. Need to make sure this works
+ # on other systems (i.e. Solaris, HP-UX, Redhat, etc.).
+ my $cmd = $system{type} eq 'Windows' ? 'df -TP' : 'df -l -TP';
+
+ my ($status, @output) = $clearexec->execute ($cmd);
+
+ error "Unable to execute uname -a - $!", $status . join ("\n". @output)
+ if $status;
+
+ # Real file systems start with "/"
+ @output = grep { /^\// } @output;
+
+ my @filesystems;
+
+ foreach (@output) {
+ if (/^(\S+)\s+(\S+).+?(\S+)$/) {
+ my %filesystem;
+
+ $filesystem{system} = $system{name};
+ $filesystem{filesystem} = $1;
+ $filesystem{fstype} = $2;
+ $filesystem{mount} = $3;
+
+ push @filesystems, \%filesystem;
+ } # if
+ } # foreach
+
+ return @filesystems;
+} # GetFilesystems
+
+sub GatherSysInfo (;%) {
+ my (%system) = @_;
+
+ # Set name if not currently set
+ $system{name} = $host
+ unless $system{name};
+
+ my ($status, @output);
+
+ $system{port} ||= $port;
+
+ # Connect to clearexec server
+ $status = $clearexec->connectToServer ($system{name}, $system{port});
+
+ unless ($status) {
+ warning "Unable to connect to $system{name}:$port";
+ return %system;
+ } # if
+
+ # Get OS info
+ my $cmd = 'uname -a';
+
+ ($status, @output) = $clearexec->execute ($cmd);
+
+ error "Unable to execute '$cmd' - $!", $status . join ("\n". @output)
+ if $status;
+
+ $system{os} = $output[0];
+
+ $system{clearagent} = 1;
+
+ $cmd = 'uname -s';
+
+ ($status, @output) = $clearexec->execute ($cmd);
+
+ error "Unable to execute '$cmd' - $!", $status . join ("\n". @output)
+ if $status;
+
+ # TODO: Need to handle this better
+ $system{type} = $output[0] =~ /cygwin/i ? 'Windows' : $output[0];
+
+ return %system;
+} # GatherSysInfo
+
+sub AddFilesystems (%) {
+ my (%system) = @_;
+
+ my ($err, $msg);
+
+ foreach (GetFilesystems %system) {
+ my %filesystem = %{$_};
+
+ my %oldfilesystem = $clearadm->GetFilesystem (
+ $filesystem{system},
+ $filesystem{filesystem}
+ );
+
+ if (%oldfilesystem) {
+ verbose "Updating filesystem $filesystem{system}:$filesystem{filesystem}";
+
+ ($err, $msg) = $clearadm->UpdateFilesystem (
+ $filesystem{system},
+ $filesystem{filesystem},
+ %filesystem,
+ );
+
+ error 'Unable to update filesystem '
+ . "$filesystem{system}:$filesystem{filesystem}"
+ if $err;
+ } else {
+ verbose 'Adding filesystem '
+ . "$filesystem{system}:$filesystem{filesystem}";
+
+ ($err, $msg) = $clearadm->AddFilesystem (%filesystem);
+
+ error 'Unable to add filesystem '
+ . "$filesystem{system}:$filesystem{filesystem}"
+ if $err;
+ } # if
+ } # foreach
+
+ return ($err, $msg);
+} # AddFilesystems
+
+sub AddSystem ($) {
+ my ($system) = @_;
+
+ verbose "Adding newhost $system";
+
+ my %system = GatherSysInfo;
+
+ # If GatherSysInfo was able to connect to clearagent it will set this field
+ my $clearagent = delete $system{clearagent};
+
+ my ($err, $msg) = $clearadm->AddSystem (%system);
+
+ return ($err, $msg)
+ if $err;
+
+ if ($clearagent) {
+ return AddFilesystems %system;
+ } else {
+ return ($err, $msg);
+ } # if
+} # AddSystem
+
+sub UpdateSystem (%) {
+ my (%system) = @_;
+
+ my ($err, $msg);
+
+ %system = GatherSysInfo (%system);
+
+ # If GatherSysInfo was able to connect to clearagent it will set this field
+ my $clearagent = delete $system{clearagent};
+
+ return ($err, $msg) unless $clearagent;
+
+ verbose "Updating existing host $system{name}";
+
+ ($err, $msg) = $clearadm->UpdateSystem ($system{name}, %system);
+
+ return ($err, $msg) if $err;
+
+ ($err, $msg) = AddFilesystems %system;
+
+ $clearexec->disconnectFromServer;
+
+ return ($err, $msg);
+} # UpdateSystem
+
+# Main
+$host = hostname;
+$port = $Clearexec::CLEAROPTS{CLEAREXEC_PORT};
+
+GetOptions (
+ 'usage' => sub { Usage },
+ 'verbose' => sub { set_verbose },
+ 'debug' => sub { set_debug },
+ 'delete' => \$delete,
+ 'host=s' => \$host,
+ 'port=s' => \$port,
+) or Usage "Invalid parameter";
+
+Usage 'Extraneous options: ' . join ' ', @ARGV
+ if @ARGV;
+
+if ($delete) {
+ error "Must specify -host if you specify -delete", 1
+ unless $host;
+} # if
+
+# Announce ourselves
+verbose "$FindBin::Script V$VERSION";
+
+my ($err, $msg);
+
+if ($delete) {
+ display_nolf "Delete host $host (y/N):";
+
+ my $answer = <STDIN>;
+
+ if ($answer =~ /(y|yes)/i) {
+ ($err, $msg) = $clearadm->DeleteSystem ($host);
+
+ if ($err == 0) {
+ error "No host named $host in database";
+ } elsif ($err < 0) {
+ error "Unable to delete $host" . $msg, $err;
+ } else {
+ verbose "Deleted host $host";
+ } # if
+ } else {
+ display "Host $host not deleted";
+ } # if
+} else {
+ if ($host eq 'all') {
+ foreach ($clearadm->FindSystem) {
+ my %system = %$_;
+
+ ($err, $msg) = UpdateSystem (%system);
+
+ error "Unable to update host $system{name}\n$msg", $err
+ if $err;
+ } # foreach
+ } else {
+ my %system = $clearadm->GetSystem ($host);
+
+ if (%system) {
+ ($err, $msg) = UpdateSystem (%system);
+ } else {
+ ($err, $msg) = AddSystem ($host);
+ } # if
+
+ if ($err) {
+ my $errmsg = 'Unable to ';
+ $errmsg .= %system ? 'update' : 'add';
+ $errmsg .= " host $host\$msg";
+
+ error "Unable to add host $host\n$msg", $err;
+ } # if
+ } # if
+} # if
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<FindBin>
+
+L<Getop::Long|Getopt::Long>
+
+L<Sys::Hostname|Sys::Hostname>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ Clearadm
+ Clearexec
+ Display
+ Utils
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/Clearadm.pm">Clearadm</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/Clearexec.pm">Clearexec</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Utils.pm">Utils</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this script
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2010, ClearSCM, Inc. All rights reserved.
+
+=cut
--- /dev/null
+clearagent.pl.pid
+.cvsignore
+cleartasks.pl.pid
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: viewager.cgi,v $
+
+View Aging
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.11 $
+
+=item Created:
+
+Mon Oct 25 11:10:47 PDT 2008
+
+=item Modified:
+
+$Date: 2011/01/14 16:50:54 $
+
+=back
+
+=head1 SYNOPSIS
+
+This script serves 4 distinct functions. One function is to find
+old views and report them to their owners via email so that view cleanup can be
+done. Another function just does a quick report stdout. Yet another function is
+to present the list of views in a web page. Finally there is a function
+(generate) which generates a cache file containing information about views. This
+function is designed to be run by a scheduler such as cron. Note that the web
+page function relies on and uses this cache file too.
+
+=head1 DESCRIPTION
+
+Most Clearcase administrators wrestle with trying to keep the number of views
+under control. Users often create views but seldom think to remove them. Views
+grow old and forgotten.
+
+Many approaches have been taken, usally emailing the users telling them to clean
+up their views. This script, viewager.cgi, attempts to encapsulate the task of
+gathering information about old views, informing users of which of their views
+are old and presenting reports in the form of a web page showing all views
+including old ones.
+
+=head1 USAGE Email, Report and Generate modes
+
+ Usage viewager.cgi: [-u|sage] [-region <region>] [-e|mail]
+ [-a|gethreshold <n>] [-n|brThreshold <n>]
+ [-ac|tion <act>] [-s|ort <field>]
+ [-v|erbose] [-d|ebug]
+
+ Where:
+ -u|sage: Displays usage
+ -region <region>: Region to use when looking for the view
+ -e|mail: Send email to owners of old views
+ -ag|eThreshold: Number of days before a view is considered old
+ (Default: 180)
+ -n|brThreshold <n>: Number of views to report. Can be used for say a
+ "top 10" old views. Useful with -action report
+ (Default: Report all views)
+ -ac|tion <act> Valid actions include 'generate' or 'report'.
+ Generate mode merely regenerates the cache file.
+ Report produces a quick report to stdout.
+ -s|ort <field>: Where <field> is one of <tag|ownerName|type|age>
+
+ -ve|rbose: Be verbose
+ -d|ebug: Output debug messages
+
+=head1 USAGE Web Page mode
+
+Parameters for the web page mode are provided by the CPAN module CGI and are
+normally passed in as part of the URL. These parameters are specified as
+name/value pairs:
+
+ sortby=<tag|ownerName|type|age>
+ Note: age will sort in a reverse numerical fashion
+
+ user=<username>
+ <username> can be a partial name (e.g. 'defaria')
+
+=head1 DESCRIPTION
+
+This script seek to handle the general issue of handling old views. In generate
+mode this script goes through all views collecting data about all of the views
+and creates a cache file. The reason for this is that this process is length
+(At one client's site with ~2500 views takes about 1 hour). As such you'd
+probably want to schedule the running of this for once a day.
+
+Once the cache file is created other modes will read that file and report on it.
+In report mode you can report to stdout. For example, the following will give
+you a quick "top 10" oldest views:
+
+ $ viewager.cgi -action report -n 10
+
+You may wish to add the following to your conrtabe to generated the cachefile
+nightly:
+
+ 0 0 * * * cd /<DocumentRoot>/viewager && /<path>/viewager.cgi -action=generate
+
+=head1 User module
+
+Since the method for translating a user's userid into other attributes like
+the users fullname and email, we rely on a User.pm module to implement a User
+object that takes a string identifying the user and return useful informaiton
+about the user, specifically the fullname and email address.
+
+=cut
+
+use strict;
+use warnings;
+
+use FindBin;
+use Getopt::Long;
+use CGI qw (:standard :cgi-lib *table start_Tr end_Tr);
+use CGI::Carp 'fatalsToBrowser';
+use File::stat;
+use Time::localtime;
+
+use lib "$FindBin::Bin/lib", "$FindBin::Bin/../lib";
+
+use Clearadm;
+use ClearadmWeb;
+use Clearcase;
+use Clearcase::View;
+use Clearcase::Views;
+use DateUtils;
+use Display;
+use Mail;
+use Utils;
+use User;
+
+my $VERSION = '$Revision: 1.11 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+my %opts = Vars;
+my $clearadm;
+
+$opts{sortby} ||= 'age';
+$opts{region} ||= $Clearcase::CC->region;
+
+my $subtitle = 'View Aging Report';
+my $email;
+
+my $port = CGI::server_port;
+ $port = ($port == 80) ? '' : ":$port";
+my $scriptName = CGI::script_name;
+ $scriptName =~ s/index.cgi//;
+my $script = 'http://'
+ . $Clearadm::CLEAROPTS{CLEARADM_SERVER}
+ . $port
+ . $scriptName;
+
+my (%total, $action);
+my $ageThreshold = 180; # Default number of days a view must be older than
+my $nbrThreshold; # Number of views threshold - think top 10
+
+sub GenerateRegion ($) {
+ my ($region) = @_;
+
+ verbose "Processing $region";
+ $total{Regions}++;
+
+ my $views = Clearcase::Views->new ($region);
+ my @Views = $views->views;
+ my @views;
+
+ verbose scalar @Views . " views to process";
+
+ my $i = 0;
+
+ foreach my $name (@Views) {
+ $total{Views}++;
+
+ if (++$i % 100 == 0) {
+ verbose_nolf $i;
+ } elsif ($i % 25 == 0) {
+ verbose_nolf '.';
+ }# if
+
+ my $view = Clearcase::View->new ($name, $region);
+
+ my $gpath;
+
+ if ($view->webview) {
+ # TODO: There doesn't appear to be a good way to get the gpath for a
+ # webview since it's set to <nogpath>! Here we try to compose one using
+ # $view->host and $view->access_path but this is decidedly Windows centric
+ # and thus not portable. This needs to be fixed!
+ $gpath = '\\\\' . $view->host . '\\' . $view->access_path;
+
+ # Change any ":" to "$". This is to change things like D:\path -> D$\path.
+ # This assumes we have permissions to access through the administrative
+ # <drive>$ mounts.
+ $gpath =~ s/:/\$/;
+ } else {
+ $gpath = $view->gpath;
+ } # if
+
+ # Note if the view server is unreachable (e.g. user puts view on laptop and
+ # the laptop is powered off), then these fields will be undef. Change them
+ # to Unknown. (Should Clearcase::View.pm do this instead?).
+ my $type = $view->type;
+ $type ||= 'Unknown';
+
+ my $user;
+
+ my $ownerid = $view->owner;
+
+ if ($ownerid) {
+ $user = User->new ($ownerid);
+
+ $user->{name} ||= 'Unknown';
+ } else {
+ $ownerid = 'Unknown';
+ $user->{name} = 'Unknown';
+ } # if
+
+ my $age = 0;
+ my $ageSuffix = '';
+
+ my $modified_date = $view->modified_date;
+
+ if ($modified_date) {
+ $modified_date = substr $modified_date, 0, 16;
+ $modified_date =~ s/T/\@/;
+
+ # Compute age
+ $age = Age ($modified_date);
+ $ageSuffix = $age != 1 ? 'days' : 'day';
+ } else {
+ $modified_date = 'Unknown';
+ } # if
+
+ my ($err, $msg) = $clearadm->AddView (
+ system => $view->shost,
+ region => $view->region,
+ tag => $view->tag,
+ owner => $ownerid,
+ ownerName => $user->{name},
+ email => $user->{email},
+ type => $type,
+ gpath => $gpath,
+ modified_date => $modified_date,
+ age => $age,
+ ageSuffix => $ageSuffix,
+ );
+
+ error "Unable to add view $name to Clearadm\n$msg", $err
+ if $err;
+ } # foreach
+
+ verbose "\nProcessed $region";
+
+ return;
+} # GenerateRegion
+
+sub Generate ($) {
+ my ($region) = @_;
+
+ if ($region =~ /all/i) {
+ foreach ($Clearcase::CC->regions) {
+ GenerateRegion $_;
+ } # foreach
+ } else {
+ GenerateRegion $region;
+ } # if
+
+ return;
+} # Generate
+
+sub Report (@) {
+ my (@views) = @_;
+
+ $total{'Views processed'} = @views;
+
+ my @sortedViews;
+
+ if ($opts{sort} eq 'age') {
+ # Sort by age numerically decending
+ @sortedViews = sort { $$b{$opts{sortby}} <=> $$a{$opts{sortby}} } @views;
+ } else {
+ @sortedViews = sort { $$a{$opts{sort}} cmp $$b{$opts{sort}} } @views;
+ } # if
+
+ $total{Reported} = 0;
+
+ foreach (@sortedViews) {
+ my %view = %{$_};
+
+ last
+ if ($nbrThreshold and $total{Reported} + 1 > $nbrThreshold) or
+ ($view{age} < $ageThreshold);
+
+ $total{Reported}++;
+
+ if ($view{type}) {
+ if ($view{type} eq 'dynamic') {
+ $total{Dynamic}++;
+ } elsif ($view{type} eq 'snapshot') {
+ $total{Snapshot}++;
+ } elsif ($view{type} eq 'webview') {
+ $total{Webview}++
+ } else {
+ $total{$view{type}}++;
+ } # if
+ } else {
+ $total{Unknown}++;
+ } # if
+
+format STDOUT_TOP =
+ View Name Owner View Type Last Modified Age
+------------------------------------- ---------------------- ----------- ---------------- -----------
+.
+format STDOUT =
+@<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<< @<<<<<<<<<<<<<<< @>>>> @<<<<
+$view{tag},$view{owner},$view{type},$view{modified_date},$view{age},$view{ageSuffix}
+.
+
+ write;
+ } # foreach
+
+ return;
+} # Report
+
+sub FormatTable ($@) {
+ my ($style, @views) = @_;
+
+ my $table;
+
+ my $nbrViews = @views;
+
+ my $legend =
+ font ({-class => 'label'}, 'View type: ') .
+ font ({-class => 'dynamic'}, 'Dyanmic') .
+ ' ' .
+ font ({-class => 'snapshot'}, 'Snapshot') .
+ ' ' .
+ font ({-class => 'web'}, 'Web') .
+ ' ' .
+ font ({-class => 'unknown'}, 'Unknown');
+
+ my $caption;
+
+ my $regionDropdown = start_form (
+ -action => $script,
+ );
+
+ $regionDropdown .= font {-class => 'captionLabel'}, 'Region: ';
+ $regionDropdown .= popup_menu (
+ -name => 'region',
+ -values => [$Clearcase::CC->regions],
+ -default => $Clearcase::CC->region,
+ -onchange => 'submit();',
+ );
+
+ $regionDropdown .= end_form;
+
+ $caption .= start_table {
+ class => 'caption',
+ cellspacing => 1,
+ width => '100%',
+ };
+
+ my $registryHost = $Clearcase::CC->registry_host;
+
+ $registryHost = font {class => 'unknown'}, 'Unknown'
+ unless $registryHost;
+
+ $caption .= start_Tr;
+ $caption .= td {
+ -align => 'left',
+ -width => '30%',
+ }, font ({-class => 'label'}, 'Registry: '),
+ $registryHost, '<br>',
+ font ({-class => 'label'}, 'Views: '),
+ $nbrViews;
+ $caption .= td {
+ -align => 'center',
+ -width => '40%',
+ }, $legend;
+ $caption .= td {
+ -align => 'right',
+ -width => '30%',
+ }, $regionDropdown;
+ $caption .= end_Tr;
+
+ $caption .= end_table;
+
+ $table .= start_table {
+ cellspacing => 1,
+ width => '75%',
+ };
+
+ $table .= caption $caption;
+ $table .= start_Tr {-class => 'heading'};
+ $table .= th '#';
+
+ # Set defaults if not set already
+ $opts{sortby} ||= 'age';
+ $opts{reverse} ||= 0;
+
+ my $parms = $opts{user} ? "&user=$opts{user}" : '';
+ $parms .= $opts{reverse} == 1 ? '&reverse=0' : '&reverse=1';
+
+ if ($style eq 'full') {
+ my $tagLabel = 'Tag ';
+ my $ownerLabel = 'Owner ';
+ my $typeLabel = 'Type ';
+ my $ageLabel = 'Age ';
+
+ if ($opts{sortby} eq 'tag') {
+ $tagLabel .= $opts{reverse} == 1
+ ? img {src => 'up.png', border => 0}
+ : img {src => 'down.png', border => 0};
+ } elsif ($opts{sortby} eq 'ownerName') {
+ $ownerLabel .= $opts{reverse} == 1
+ ? img {src => 'up.png', border => 0}
+ : img {src => 'down.png', border => 0};
+ } elsif ($opts{sortby} eq 'type') {
+ $typeLabel .= $opts{reverse} == 1
+ ? img {src => 'up.png', border => 0}
+ : img {src => 'down.png', border => 0};
+ } elsif ($opts{sortby} eq 'age') {
+ $ageLabel .= $opts{reverse} == 1
+ ? img {src => 'down.png', border => 0}
+ : img {src => 'up.png', border => 0};
+ } # if
+
+ $table .= th a {href => "$script?region=$opts{region}&sortby=tag$parms"},
+ $tagLabel;
+ $table .= th a {href => "$script?region=$opts{region}&sortby=ownerName$parms"},
+ $ownerLabel;
+ $table .= th a {href => "$script?region=$opts{region}&sortby=type$parms"},
+ $typeLabel;
+ $table .= th a {href => "$script?region=$opts{region}&sortby=age$parms"},
+ $ageLabel;
+ } else {
+ $table .= th 'Tag';
+ $table .= th 'Owner';
+ $table .= th 'Type';
+ $table .= th 'Age';
+ } # if
+ $table .= end_Tr;
+
+ if ($opts{sortby} eq 'age') {
+ # Sort by age numerically decending
+ @views = $opts{reverse} == 1
+ ? sort { $$a{$opts{sortby}} <=> $$b{$opts{sortby}} } @views
+ : sort { $$b{$opts{sortby}} <=> $$a{$opts{sortby}} } @views
+ } else {
+ @views = $opts{reverse} == 1
+ ? sort { $$b{$opts{sortby}} cmp $$a{$opts{sortby}} } @views
+ : sort { $$a{$opts{sortby}} cmp $$b{$opts{sortby}} } @views
+ } # if
+
+ my $i;
+
+ foreach (@views) {
+ my %view = %{$_};
+
+ my $owner = $view{owner};
+
+ if ($view{owner} =~ /\S+(\\|\/)(\S+)/) {
+ $owner = $2;
+ } # if
+
+ $owner = $view{ownerName} ? $view{ownerName} : 'Unknown';
+
+ my $rowClass= $view{age} > $ageThreshold ? 'oldview' : 'view';
+
+ $table .= start_Tr {
+ class => $rowClass
+ };
+ $table .= td {
+ class => 'center',
+ }, ++$i;
+ $table .= td {
+ align => 'left',
+ }, a {
+ href => "viewdetails.cgi?tag=$view{tag}®ion=$opts{region}"
+ }, $view{tag};
+ $table .= td {
+ align => 'left',
+ }, a {
+ href => "$script?region=$opts{region}&user=$owner"
+ }, $owner;
+ $table .= td {
+ class => 'center'
+ }, font {
+ class => $view{type}
+ }, $view{type};
+ $table .= td {
+ class => 'right'
+ }, font ({
+ class => $view{type}
+ }, $view{age}, ' ', $view{ageSuffix});
+ $table .= end_Tr;
+ } # foreach
+
+ $table .= end_table;
+
+ return $table
+} # FormatTable
+
+# TODO: Add an option to remove views older than a certain date
+
+sub EmailUser ($@) {
+ my ($emailTo, @oldViews) = @_;
+
+ @oldViews = sort { $$b{age} <=> $$a{age} } @oldViews;
+
+ my $msg = '<style>' . join ("\n", ReadFile 'viewager.css') . '</style>';
+ $msg .= <<"END";
+<h1 align="center">You have old Clearcase Views</h1>
+
+<p>Won't you take a moment to review this message and clean up any views you no
+longer need?</p>
+
+<p>The following views are owned by you and have not been modified in $ageThreshold
+days:</p>
+END
+
+ $msg .= FormatTable 'partial', @oldViews;
+ $msg .= <<"END";
+
+<h3>How to remove views you no longer need</h3>
+
+<p>There are several ways to remove Clearcase views, depending on the view
+type and the tools you are using.</p>
+
+<blockquote>
+ <p><b>Dynamic Views</b>: If the view is a dynamic view you can use Clearcase
+ Explorer to remove the view. Find the view in your Clearcase Explorer. If
+ it's not there then add it as a standard view shortcut. Then right click on
+ the view shortcut and select <b>Remove View</b> (not <b>Remove View
+ Shortcut</b>).</p>
+
+ <p><b>Snapshot Views</b>: A snapshot view is a view who's source storage can
+ be located locally. You can remove a snapshot view in a similar manner as a
+ dynamic view, by adding it to Clearcase Explorer if not already present. By
+ doing so you need to tell Clearcase Explorer where the snapshot view storage
+ is located.</p>
+
+ <p><b>Webviews</b>: Webviews are like snapshot views but stored on the web
+ server. If you are using CCRC or the CCRC plugin to Eclipse you would select
+ the view and then do <b>Environment: Remove Clearcase View</b>.</p>
+</blockquote>
+
+<p>If you have any troubles removing your old views then submit a case and we
+will be happy to assist you.</p>
+
+<h3>But I need for my view to stay around even if it hasn't been modified</h3>
+
+<p>If you have a long lasting view who does not get modified but needs to
+remain, contact us and we can arrange for it to be removed from consideration
+which will stop it from being reported as old.</p>
+
+<p>Thanks.</p>
+-- <br>
+Your friendly Clearcase Administrator
+END
+
+ mail (
+ to => $emailTo,
+# to => 'Andrew@DeFaria.com',
+ mode => 'html',
+ subject => 'Old views',
+ data => $msg,
+ );
+
+ return
+} # EmailUser
+
+sub EmailUsers (@) {
+ my (@views) = @_;
+
+ @views = sort { $$a{ownerName} cmp $$b{ownerName} } @views;
+
+ my @userViews;
+ my $currUser = $views [0]->{ownerName};
+
+ foreach (@views) {
+ my %view = %{$_};
+
+ next
+ unless $view{email};
+
+ if ($currUser ne $view{ownerName}) {
+ EmailUser $view{email}, @userViews
+ if @userViews;
+
+ $currUser = $view{ownerName};
+
+ @userViews =();
+ } else {
+ if ($view{age} > $ageThreshold) {
+ push @userViews, \%view
+ if !-f "$view{gpath}/ageless";
+ } # if
+ } # if
+ } # foreach
+
+ display"Done";
+
+ return;
+} # EmailUsers
+
+# Main
+GetOptions (
+ \%opts,
+ 'usage' => sub { Usage },
+ 'verbose' => sub { set_verbose },
+ 'debug' => sub { set_debug },
+ 'region=s',
+ 'sortby=s',
+ 'action=s',
+ 'email',
+ 'ageThreshold=i',
+ 'nbrThreshold=i',
+) or Usage "Invalid parameter";
+
+local $| = 1;
+
+$opts{region} ||= '';
+
+# Announce ourselves
+verbose "$FindBin::Script v$VERSION";
+
+$clearadm = Clearadm->new;
+
+if ($action and $action eq 'generate') {
+ Generate $opts{region};
+ Stats \%total;
+} else {
+ if ($opts{region} and ($opts{region} eq 'Clearcase not installed')) {
+ heading;
+ displayError $opts{region};
+ footing;
+ exit 1;
+ } # if
+
+ my @views = $clearadm->FindView (
+ 'all',
+ $opts{region},
+ $opts{tag},
+ $opts{user}
+ );
+
+ if ($action and $action eq 'report') {
+ Report @views;
+ Stats \%total;
+ } elsif ($email) {
+ EmailUsers @views;
+ } else {
+ heading $subtitle;
+
+ display h1 {
+ -class => 'center',
+ }, $subtitle;
+
+ display FormatTable 'full', @views;
+
+ footing;
+ } # if
+} # if
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<CGI>
+
+L<CGI::Carp|CGI::Carp>
+
+L<Data::Dumper|Data::Dumper>
+
+L<File::stat|File::stat>
+
+L<FindBin>
+
+L<Getopt::Long|Getopt::Long>
+
+L<Time::localtime|Time::localtime>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ Clearadm
+ ClearadmWeb
+ Clearcase
+ Clearcase::View
+ Clearcase::Views
+ DateUtils
+ Display
+ Mail
+ Utils
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/Clearadm.pm">Clearadm</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/ClearadmWeb.pm">ClearadmWeb</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Clearcase.pm">Clearcase</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Clearcase/View.pm">Clearcase::View</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Clearcase/Views.pm">Clearcase::Views</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/DateUtils.pm">DateUtils</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Mail.pm">Mail</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Utils.pm">Utils</a><br>
+</blockquote>
+
+=end html
+
+=head2 User module
+
+L<User>
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this script
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2010, ClearSCM, Inc. All rights reserved.
+
+=cut
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: viewdetails.cgi,v $
+
+View Details
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.11 $
+
+=item Created:
+
+Mon Oct 25 11:10:47 PDT 2008
+
+=item Modified:
+
+$Date: 2011/01/14 16:51:58 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage viewdetails.cgi: [-u|sage] [-r|egion <region>] -vi|ew <viewname>
+ [-ve|rbose] [-d|ebug]
+
+ Where:
+ -u|sage: Displays usage
+ -r|egion <region>: Region to use when looking for the view
+ -vi|ew<viewname>: Name of view to display details for
+
+ -ve|rbose: Be verbose
+ -d|ebug: Output debug messages
+
+=head2 DESCRIPTION
+
+This script display the details for the given view
+
+=cut
+
+use strict;
+use warnings;
+
+use FindBin;
+use Getopt::Long;
+use CGI qw (:standard :cgi-lib *table start_Tr end_Tr);
+use CGI::Carp 'fatalsToBrowser';
+
+use lib "$FindBin::Bin/lib", "$FindBin::Bin/../lib";
+
+use ClearadmWeb;
+use Clearcase;
+use Clearcase::View;
+use Clearcase::Views;
+use Display;
+use Utils;
+
+my %opts = Vars;
+
+my $subtitle = 'View Details';
+
+if ($Clearcase::CC->region) {
+ $opts{region} ||= $Clearcase::CC->region;
+} else {
+ $opts{region} ||= 'Clearcase not installed';
+} # if
+
+my $VERSION = '$Revision: 1.11 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+sub DisplayTable ($) {
+ my ($view) = @_;
+
+ # Data fields
+ my $tag = setField $view->tag;
+ my $server = setField $view->shost;
+ my $region = setField $view->region;
+ my $properties = setField $view->properties;
+ my $text_mode = setField $view->text_mode;
+ my $permissions = setField $view->owner_mode
+ . setField $view->group_mode
+ . setField $view->other_mode;
+ my $owner = setField $view->owner;
+ my $active = ($view->active) ? 'YES' : 'NO';
+ my $created_by = setField $view->created_by;
+ my $created_date = setField $view->created_date;
+ my $cs_updated_by = setField $view->cs_updated_by;
+ my $cs_updated_date = setField $view->cs_updated_date;
+ my $gpath = setField $view->gpath;
+ my $access_path = setField $view->access_path;
+ my $uuid = setField $view->uuid;
+
+ $gpath = font {-class => 'unknown'}, '<no-gpath>'
+ if $gpath eq '<no-gpath>';
+
+ display start_table {
+ -cellspacing => 1,
+ -class => 'main',
+ };
+
+ display start_Tr;
+ display th {class => 'label'}, 'Tag:';
+ display td {class => 'data', colspan => 3}, $tag;
+ display th {class => 'label'}, 'Server:';
+ display td {class => 'data'}, a {
+ href => "serverdetails.cgi?server=$server"
+ }, $server;
+ display th {class => 'label'}, 'Region:';
+ display td {class => 'data'}, $region;
+ display end_Tr;
+
+ display start_Tr;
+ display th {class => 'label'}, 'Properties:';
+ display td {class => 'data', colspan => 3}, $properties;
+ display th {class => 'label'}, 'Text Mode:';
+ display td {class => 'data'}, $text_mode;
+ display th {class => 'label'}, 'Permission:';
+ display td {class => 'data'}, $permissions;
+ display end_Tr;
+
+ display start_Tr;
+ display th {class => 'label'}, 'Owner:';
+ display td {class => 'data', colspan => 3}, $owner;
+ display th {class => 'label'}, 'Active:';
+ display td {class => 'data', colspan => 3}, $active;
+ display end_Tr;
+
+ display start_Tr;
+ display th {class => 'label'}, 'Created by:';
+ display td {class => 'data', colspan => 3}, $created_by;
+ display th {class => 'label'}, 'on:';
+ display td {class => 'data', colspan => 3}, $created_date;
+ display end_Tr;
+
+ display start_Tr;
+ display th {class => 'label'}, 'CS Updated by:';
+ display td {class => 'data', colspan => 3}, $cs_updated_by;
+ display th {class => 'label'}, 'on:';
+ display td {class => 'data', colspan => 3}, $cs_updated_date;
+ display end_Tr;
+
+ display start_Tr;
+ display th {class => 'label'}, 'Global Path:';
+ display td {class => 'data', colspan => 7}, $gpath;
+ display end_Tr;
+
+ display start_Tr;
+ display th {class => 'label'}, 'Access Path:';
+ display td {class => 'data', colspan => 7}, $access_path;
+ display end_Tr;
+
+ display start_Tr;
+ display th {class => 'label'}, 'UUID:';
+ display td {class => 'data', colspan => 7}, $uuid;
+ display end_Tr;
+
+ display end_table;
+
+ return
+} # DisplayTable
+
+sub DisplayRegion {
+ display start_form (action => 'viewdetails.cgi');
+
+ display 'Region ';
+
+ my ($defaultRegion, @regions) = ('', ('Clearcase not installed'));
+
+ display popup_menu (
+ -name => 'region',
+ -values => [@regions],
+ -default => $defaultRegion,
+ -onchange => 'submit();',
+ );
+
+ display submit (
+ -value => 'Go',
+ );
+
+ display end_form;
+
+ return
+} # DisplayRegion
+
+sub DisplayViews ($) {
+ my ($region) = @_;
+
+ my $views = Clearcase::Views->new ($region);
+ my @views = $views->views;
+
+ unless (@views) {
+ push @views, 'No Views';
+ } # unless
+
+ display start_form (action => 'viewdetails.cgi');
+
+ display 'Region ';
+
+ display popup_menu (
+ -name => 'region',
+ -values => [$Clearcase::CC->regions],
+ -default => $region,
+ -onchange => 'submit();',
+ );
+
+ display b ' View: ';
+
+ display popup_menu (
+ -name => 'view',
+ -values => \@views,
+ -onchange => 'submit();',
+ );
+
+ display submit (
+ -value => 'Go',
+ );
+
+ display end_form;
+
+ return;
+} # DisplayViews
+
+# Main
+GetOptions (
+ \%opts,
+ 'usage' => sub { Usage },
+ 'verbose' => sub { set_verbose },
+ 'debug' => sub { set_debug },
+ 'view=s',
+ 'region=s',
+) or Usage "Invalid parameter";
+
+# Announce ourselves
+verbose "$FindBin::Script v$VERSION";
+
+heading $subtitle;
+
+display h1 {
+ -class => 'center',
+}, $subtitle;
+
+unless ($opts{tag}) {
+ unless ($opts{region}) {
+ DisplayRegion;
+ } else {
+ DisplayViews $opts{region};
+ } # unless
+
+ exit;
+} # unless
+
+my $view = Clearcase::View->new ($opts{tag}, $opts{region});
+
+DisplayTable $view;
+
+footing;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<CGI>
+
+L<CGI::Carp|CGI::Carp>
+
+L<FindBin>
+
+L<Getopt::Long|Getopt::Long>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ ClearadmWeb
+ Clearcase
+ Clearcase::View
+ Clearcase::Views
+ Display
+ Utils
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/ClearadmWeb.pm">ClearadmWeb</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Clearcase.pm">Clearcase</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Clearcase/View.pm">Clearcase::View</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Clearcase/Views.pm">Clearcase::Views</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Utils.pm">Utils</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this script
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2010, ClearSCM, Inc. All rights reserved.
+
+=cut
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: viewservers.cgi,v $
+
+View Details
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.9 $
+
+=item Created:
+
+Mon Oct 25 11:10:47 PDT 2008
+
+=item Modified:
+
+$Date: 2011/01/02 15:25:23 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage viewservers.cgi: [-u|sage] [-r|egion <region>]
+ [-ve|rbose] [-d|ebug]
+
+ Where:
+ -u|sage: Displays usage
+ -r|egion <region>: Region to use when looking for the view
+
+ -ve|rbose: Be verbose
+ -d|ebug: Output debug messages
+
+=head1 DESCRIPTION
+
+This script display the details for all view servers in the region
+
+=cut
+
+use strict;
+use warnings;
+
+use FindBin;
+use Getopt::Long;
+use CGI qw (:standard :cgi-lib *table start_Tr end_Tr);
+use CGI::Carp 'fatalsToBrowser';
+
+use lib "$FindBin::Bin/lib", "$FindBin::Bin/../lib";
+
+use ClearadmWeb;
+use Clearcase;
+use Clearcase::Server;
+use Display;
+use Utils;
+
+my %opts = Vars;
+
+$opts{region} ||= $Clearcase::CC->region;
+
+my $subtitle = 'View Servers';
+
+my $VERSION = '$Revision: 1.9 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+sub DisplayTable (@) {
+ my (@viewServers) = @_;
+
+ my $unknown = font {-class => 'unknown'}, 'Unknown';
+
+ display start_table {
+ -cellspacing => 1,
+ -class => 'main',
+ };
+
+ display start_Tr;
+ display th {
+ -class => 'labelCentered',
+ }, '#';
+ display th {
+ -class => 'labelCentered',
+ }, 'Server';
+ display th {
+ -class => 'labelCentered',
+ }, 'CC Version';
+ display th {
+ -class => 'labelCentered',
+ }, 'OS Version';
+ display end_Tr;
+
+ my $i = 0;
+
+ foreach (@viewServers) {
+ my $server = Clearcase::Server->new ($_, $opts{region});
+
+ # Data fields
+ my $name = $server->name;
+ my $ccVer = $server->ccVer;
+ my $osVer = $server->osVer;
+
+ $ccVer ||= $unknown;
+ $osVer ||= $unknown;
+
+ display start_Tr;
+ display td {
+ -class => 'dataCentered',
+ }, ++$i;
+ display td {
+ -class => 'data',
+ }, a {-href => "serverdetails.cgi?server=$name"}, $name;
+ display td {
+ -class => 'data',
+ }, $ccVer;
+ display td {
+ -class => 'data',
+ }, $osVer;
+ display end_Tr;
+ } # foreach
+
+ display end_table;
+
+ return;
+} # DisplayTable
+
+# Main
+GetOptions (
+ \%opts,
+ 'usage' => sub { Usage },
+ 'verbose' => sub { set_verbose },
+ 'debug' => sub { set_debug },
+ 'region=s',
+) or Usage "Invalid parameter";
+
+# Announce ourselves
+verbose "$FindBin::Script v$VERSION";
+
+heading $subtitle;
+
+display h1 {
+ -class => 'center',
+}, $subtitle;
+
+my ($status, @output) = $Clearcase::CC->execute ("lsview -region $opts{region} -long");
+
+error "Unable to list all views in the region $opts{region}" . join ("\n", @output), 1
+ if $status;
+
+my %viewServers;
+
+foreach (@output) {
+ if (/Server host: (.*)/) {
+ $viewServers{$1} = undef;
+ } # if
+} # foreach
+
+DisplayTable sort (keys (%viewServers));
+
+footing;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<CGI>
+
+L<CGI::Carp|CGI::Carp>
+
+L<FindBin>
+
+L<Getopt::Long|Getopt::Long>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ ClearadmWeb
+ Clearcase
+ Clearcase::Server
+ Display
+ Utils
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/ClearadmWeb.pm">ClearadmWeb</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Clearcase.pm">Clearcase</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Clearcase/Server.pm">Clearcase::Server</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Utils.pm">Utils</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this script
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2010, ClearSCM, Inc. All rights reserved.
+
+=cut
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: vobservers.cgi,v $
+
+View Details
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.9 $
+
+=item Created:
+
+Mon Oct 25 11:10:47 PDT 2008
+
+=item Modified:
+
+$Date: 2011/01/02 15:25:42 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage vobservers.cgi: [-u|sage] [-r|egion <region>]
+ [-ve|rbose] [-d|ebug]
+
+ Where:
+ -u|sage: Displays usage
+ -r|egion <region>: Region to use when looking for the view
+
+ -ve|rbose: Be verbose
+ -d|ebug: Output debug messages
+
+=head1 DESCRIPTION
+
+This script display the details for all vob servers in the region
+
+=cut
+
+use strict;
+use warnings;
+
+use FindBin;
+use Getopt::Long;
+use CGI qw (:standard :cgi-lib *table start_Tr end_Tr);
+use CGI::Carp 'fatalsToBrowser';
+
+use lib "$FindBin::Bin/lib", "$FindBin::Bin/../lib";
+
+use ClearadmWeb;
+use Clearcase;
+use Clearcase::Server;
+use Display;
+use Utils;
+
+my %opts = Vars;
+
+$opts{region} ||= $Clearcase::CC->region if $Clearcase::CC;
+
+my $subtitle = 'Vob Servers';
+
+my $VERSION = '$Revision: 1.9 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+sub DisplayTable (@) {
+ my (@vobServers) = @_;
+
+ my $unknown = font {-class => 'unknown'}, 'Unknown';
+
+ display start_table {
+ -cellspacing => 1,
+ -class => 'main',
+ };
+
+ display start_Tr;
+ display th {
+ -class => 'labelCentered',
+ }, '#';
+ display th {
+ -class => 'labelCentered',
+ }, 'Server';
+ display th {
+ -class => 'labelCentered',
+ }, 'CC Version';
+ display th {
+ -class => 'labelCentered',
+ }, 'OS Version';
+ display end_Tr;
+
+ my $i = 0;
+
+ foreach (@vobServers) {
+ my $server = Clearcase::Server->new ($_, $opts{region});
+
+ # Data fields
+ my $name = $server->name;
+ my $ccVer = $server->ccVer;
+ my $osVer = $server->osVer;
+
+ $ccVer ||= $unknown;
+ $osVer ||= $unknown;
+
+ display start_Tr;
+ display td {
+ -class => 'dataCentered',
+ }, ++$i;
+ display td {
+ -class => 'data',
+ }, a {-href => "serverdetails.cgi?server=$name"}, $name;
+ display td {
+ -class => 'data',
+ }, $ccVer;
+ display td {
+ -class => 'data',
+ }, $osVer;
+ display end_Tr;
+ } # foreach
+
+ display end_table;
+
+ return;
+} # DisplayTable
+
+# Main
+GetOptions (
+ \%opts,
+ 'usage' => sub { Usage },
+ 'verbose' => sub { set_verbose },
+ 'debug' => sub { set_debug },
+ 'region=s',
+) or Usage "Invalid parameter";
+
+# Announce ourselves
+verbose "$FindBin::Script v$VERSION";
+
+heading $subtitle;
+
+display h1 {
+ -class => 'center',
+}, $subtitle;
+
+my ($status, @output) = $Clearcase::CC->execute (
+ "lsvob -region $opts{region} -long"
+);
+
+error "Unable to list all vobs in the region $opts{region}"
+ . join ("\n", @output), 1
+ if $status;
+
+my %vobServers;
+
+foreach (@output) {
+ if (/Server host: (.*)/) {
+ $vobServers{$1} = undef;
+ } # if
+} # foreach
+
+DisplayTable sort (keys (%vobServers));
+
+footing;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<CGI>
+
+L<CGI::Carp|CGI::Carp>
+
+L<FindBin>
+
+L<Getopt::Long|Getopt::Long>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ ClearadmWeb
+ Clearcase
+ Clearcase::Server
+ Display
+ Utils
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=clearadm/lib/ClearadmWeb.pm">ClearadmWeb</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Clearcase.pm">Clearcase</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Clearcase/Server.pm">Clearcase::Server</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Utils.pm">Utils</a><br>
+</blockquote>
+
+=end html
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this script
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2010, ClearSCM, Inc. All rights reserved.
+
+=cut
\ No newline at end of file
--- /dev/null
+#!cqperl
+################################################################################
+#
+# File: CheckCodePage.pl
+# Description: With Clearquest 2003.06.15 there is more support for
+# internationalization. This means that Clearquest now
+# implements a Code Page which essentially defines the
+# valid character set for data. If it encounters invalid
+# characters the user must correct them.
+#
+# This script will check a Clearquest database to see if
+# there are any invalid ASCII characters in string oriented
+# fields.
+# Author: Andrew@DeFaria.com
+# Created: Fri Sep 23 17:27:58 PDT 2005
+# Language: Perl
+#
+# (c) Copyright 2005, Andrew@DeFaria.com, all rights reserved
+#
+################################################################################
+use strict;
+use warnings;
+use CQPerlExt;
+use File::Spec;
+
+our ($me, $SEPARATOR);
+
+my ($abs_path, $lib_path);
+
+BEGIN {
+ # Extract relative path and basename from script name.
+ $0 =~ /(.*)[\/\\](.*)/;
+
+ $abs_path = (!defined $1) ? "." : File::Spec->rel2abs ($1);
+ $me = (!defined $2) ? $0 : $2;
+ $me =~ s/\.pl$//;
+
+ # Remove .pl for Perl scripts that have that extension
+ $me =~ s/\.pl$//;
+
+ # Define the path separator
+ $SEPARATOR = ($^O =~ /MSWin/) ? "\\" : "/";
+
+ # Setup paths
+ $lib_path = "$abs_path" . $SEPARATOR . ".." . $SEPARATOR . "lib";
+
+ # Add the appropriate path to our modules to @INC array.
+ unshift (@INC, "$abs_path");
+ unshift (@INC, "$lib_path");
+} # BEGIN
+
+use PQA;
+use Display;
+use Logger;
+use TimeUtils;
+
+my $from_db_connection_name = "Controller";
+
+sub Usage {
+ my $msg = shift;
+
+ display "ERROR: $msg\n" if defined $msg;
+
+ display "Usage: $me\t[-u] [-v] [-d] [-from <connection name>]
+
+Where:
+
+ -u: Display usage
+ -v: Turn on verbose mode
+ -d: Turn on debug mode
+ -from <connection name>: Specify the from connection name
+ (Default: $from_db_connection_name)";
+ exit 1;
+} # Usage
+
+while ($ARGV [0]) {
+ if ($ARGV [0] eq "-v") {
+ Display::set_verbose;
+ Logger::set_verbose;
+ } elsif ($ARGV [0] eq "-d") {
+ set_debug;
+ } elsif ($ARGV [0] eq "-from") {
+ shift;
+ if (!$ARGV [0]) {
+ Usage "Must specify <connection name> after -from";
+ } else {
+ $from_db_connection_name = $ARGV [0];
+ } # if
+ } elsif ($ARGV [0] eq "-u") {
+ Usage;
+ } else {
+ Usage "Unknown argument found: " . $ARGV [0];
+ } # if
+
+ shift (@ARGV);
+} # while
+
+my $log = Logger->new (path => ".");
+
+my $process_start_time = time;
+my $start_time;
+
+$log->msg ("Starting Cont session");
+my $session = StartSession ("Cont", $from_db_connection_name);
+
+$start_time = time;
+
+#$log->msg ("Checking customer record...");
+#CheckRecord $log, $session, "dbid", "customer", undef, @customer_fields;
+
+#$log->msg ("Checking project record...");
+#CheckRecord $log, $session, "dbid", "project", undef, @project_fields;
+
+$log->msg ("Checking defect record...");
+#CheckRecord $log, $session, "id", "defect", undef, @new_Cont_defect_fields;
+CheckRecord $log, $session, "id", "defect", "Cont00022003", @new_Cont_defect_fields;
+
+$log->msg ("Ending Cont session...");
+EndSession $session;
+
+display_duration $start_time, $log;
+
+
+$log->msg ("\nInvalid character analysis\n");
+
+my $i = 0;
+
+foreach (sort (keys (%bad_chars))) {
+ $log->msg (++$i . "\t$_\t$bad_chars{$_}\n");
+} # foreach
+
+display_duration $process_start_time, $log;
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: PQA.pm
+# Description: Perl module PQA conversion routines
+# Author: Andrew@DeFaria.com
+# Created: Thu Oct 6 09:51:38 PDT 2005
+# Language: Perl
+# Modifications:
+#
+# (c) Copyright 2005, Andrew@DeFaria.com, all rights reserved
+#
+################################################################################
+#use strict;
+use warnings;
+use CQPerlExt;
+
+package PQA;
+ use File::Spec;
+
+ require (Exporter);
+ @ISA = qw (Exporter);
+
+ @EXPORT = qw (
+ @old_Prod_defect_fields
+ @old_TO_defect_fields
+ @new_Cont_defect_fields
+ @customer_fields
+ @project_fields
+ %bad_chars
+ AddToFieldChoiceList
+ AddToProject
+ CheckField
+ CheckRecord
+ DeleteDynamicLists
+ DeleteRecords
+ EndSession
+ GetAllDefectRecords
+ GetDefectRecord
+ ProjectExists
+ StartSession
+ TransferAttachments
+ TransferHistory
+ TransferRecords
+ );
+
+ # Forwards
+ sub AddToFieldChoiceList;
+ sub AddToProject;
+ sub CheckField;
+ sub CheckRecord;
+ sub DeleteDynamicLists;
+ sub DeleteRecords;
+ sub EndSession;
+ sub GetAllDefectRecords;
+ sub GetDefectRecord;
+ sub ProjectExists;
+ sub StartSession;
+ sub TransferAttachemnts;
+ sub TransferHistory;
+ sub TransferRecords;
+
+ our ($me, $verbose, $debug);
+ my $abs_path;
+
+ BEGIN {
+ # Check environment variables
+ $verbose = $ENV {VERBOSE} ? "yes" : "no";
+ $debug = $ENV {DEBUG} ? "yes" : "no";
+ } # BEGIN
+
+ use Display;
+ use Logger;
+
+ ## Exported variables ##
+
+ # Field Definitions
+ our @old_Prod_defect_fields = (
+ "ActionNotes", # SHORT_STRING
+ "AdvancedFeature", # SHORT_STRING, CONSTANT_LIST
+ "Assigned_Date", # DATE_TIME
+ "AttachmentBRCM", # ATTACHMENT_LIST
+ "Audit_Log", # MULTILINE_STRING
+ "Category", # SHORT_STRING, CONSTANT_LIST
+ "Close_Date", # DATE_TIME
+ "CommitmentLevel", # SHORT_STRING, CONSTANT_LIST
+ "CommittedDate", # DATE_TIME
+ "CommittedToProject", # SHORT_STRING, CONSTANT_LIST
+ "CustomerID", # SHORT_STRING
+ "DataPendingNote", # MULTILINE_STRING
+ "DeferredToChip", # SHORT_STRING
+ "DeferredToProject", # SHORT_STRING, CONSTANT_LIST
+ "Description", # MULTILINE_STRING
+ "DoesNotVerifyNote", # MULTILINE_STRING
+ "Entry_Type", # SHORT_STRING, CONSTANT_LIST
+ "Est_Time_To_Fix", # SHORT_STRING
+ "Fixed_In_HW_Version", # SHORT_STRING
+ "Fixed_In_Project", # SHORT_STRING, CONSTANT_LIST
+ "Fixed_In_SW_Version", # SHORT_STRING
+ "GatingItem", # SHORT_STRING, CONSTANT_LIST
+ "HUT", # SHORT_STRING, DYNAMIC_LIST
+ "HUT_Revision", # SHORT_STRING, CONSTANT_LIST
+ "HUT_Version", # SHORT_STRING, CONSTANT_LIST
+ "History", # JOURNAL
+ "Issue_Classification", # SHORT_STRING, CONSTANT_LIST
+ "Keywords", # MULTILINE_STRING, CONSTANT_LIST
+ "NoteBRCMOnly", # MULTILINE_STRING
+ "NoteBugReview", # MULTILINE_STRING
+ "Note_Entry", # MULTILINE_STRING
+ "Notes_Log", # MULTILINE_STRING
+ "OEMSubmitterName", # SHORT_STRING
+ "OS", # CONSTANT_LIST
+ "Open_Close_Status", # SHORT_STRING, CONSTANT_LIST
+ "Owner", # REFERENCE
+ "PendingHWSWReleases", # INT
+ "Priority", # SHORT_STRING, CONSTANT_LIST
+ "Project", # REFERENCE
+ "Project_Name", # SHORT_STRING, CONSTANT_LIST
+ "RelatedID", # MULTILINE_STRING
+ "ReportedBy", # SHORT_STRING, CONSTANT_LIST
+ "Resolution", # SHORT_STRING
+ "ResolveNote", # MULTILINE_STRING
+ "ResolvedBy", # REFERENCE
+ "Resolved_Date", # DATE_TIME
+ "SQATestCase", # SHORT_STRING, CONSTANT_LIST
+ "Service_Pack", # SHORT_STRING
+ "Severity", # SHORT_STRING, CONSTANT_LIST
+ "Software", # SHORT_STRING, CONSTANT_LIST
+ "Software_Version", # SHORT_STRING
+ "Submit_Date", # DATE_TIME
+ "Submitter", # REFERENCE
+ "Symptoms", # MULTILINE_STRING, CONSTANT_LIST
+ "TCProcedure", # MULTILINE_STRING
+ "TestBlocking", # SHORT_STRING, CONSTANT_LIST
+ "TestCaseID", # INT
+ "TestcaseComment", # MULTILINE_STRING
+ "TimeFromSubmitToVerify", # SHORT_STRING
+ "TimeSubmitToResolve", # SHORT_STRING
+ "TimeSubmitToResolve", # SHORT_STRING
+ "TimeToVerify", # SHORT_STRING
+ "Title", # SHORT_STRING
+ "VerifiedBy", # REFERENCE
+ "VerifyNote", # MULTILINE_STRING
+ "Verified_Date", # DATE_TIME
+ "Verified_In_HW_Version", # SHORT_STRING
+ "Verified_In_SW_Version", # SHORT_STRING
+ "Visibility", # SHORT_STRING, CONSTANT_LIST
+ "VisibleTo3com", # INT
+ "VisibleToAltima", # INT
+ "VisibleToCompaq", # INT
+ "VisibleToDell", # INT
+ "customer", # REFERENCE
+ "customer_severity", # SHORT_STRING, CONSTANT_LIST
+ "old_id", # SHORT_STRING, CONSTANT_LIST
+ );
+
+ # This decribes the fields in the old TO defect record
+ our @old_TO_defect_fields = (
+ "ActionNotes", # SHORT_STRING
+ "AdvancedFeature", # SHORT_STRING, DYNAMIC_LIST
+ "Assigned_Date", # DATE_TIME
+ "AttachmentsBRCM", # ATTACHMENT_LIST
+ "Audit_Log", # MULTILINE_STRING
+ "Category", # SHORT_STRING, CONSTANT_LIST
+ "Close_Date", # DATE_TIME
+ "CommitmentLevel", # SHORT_STRING, CONSTANT_LIST
+ "CommittedDate", # DATE_TIME
+ "CommittedToProject", # SHORT_STRING, DYNAMIC_LIST
+ "CustomerID", # SHORT_STRING
+ "DataPendingNote", # MULTILINE_STRING
+ "DeferredToChip", # SHORT_STRING
+ "DeferredToProject", # SHORT_STRING, DYNAMIC_LIST
+ "Description", # MULTILINE_STRING
+ "DoesNotVerifyNote", # MULTILINE_STRING
+ "Entry_Type", # SHORT_STRING, CONSTANT_LIST
+ "Est_Time_To_Fix", # SHORT_STRING
+ "Fixed_In_HW_Version", # SHORT_STRING
+ "Fixed_In_Project", # SHORT_STRING, DYNAMIC_LIST
+ "Fixed_In_SW_Version", # SHORT_STRING
+ "Found_In_Project", # SHORT_STRING, DYNAMIC_LIST
+ "GatingItem", # SHORT_STRING, CONSTANT_LIST
+ "HUT", # SHORT_STRING, DYNAMIC_LIST
+ "HUT_Revision", # SHORT_STRING, DYNAMIC_LIST
+ "HUT_Version", # SHORT_STRING, DYNAMIC_LIST
+ "Headline", # SHORT_STRING
+ "History", # JOURNAL
+ "Issue_Classification", # SHORT_STRING, CONSTANT_LIST
+ "Keywords", # MULTILINE_STRING, CONSTANT_LIST
+ "NoteBRCMOnly", # MULTILINE_STRING
+ "NoteBugReview", # MULTILINE_STRING
+ "Note_Entry", # MULTILINE_STRING
+ "Notes_Log", # MULTILINE_STRING
+ "OEMSubmitterName", # SHORT_STRING
+ "OS", # SHORT_STRING, DYNAMIC_LIST
+ "Open_Close_Status", # SHORT_STRING, CONSTANT_LIST
+ "Owner", # REFERENCE
+ "PendingHWSWReleases", # INT
+ "Priority", # SHORT_STRING, CONSTANT_LIST
+ "Project", # REFERENCE
+ "ReportedBy", # REFERENCE
+ "Resolution", # SHORT_STRING, CONSTANT_LIST
+ "ResolveNote", # MULTILINE_STRING
+ "ResolvedBy", # REFERENCE
+ "Resolved_Date", # DATE_TIME
+ "SQATestCase", # SHORT_STRING, CONSTANT_LIST
+ "Service_Pack", # SHORT_STRING, DYNAMIC_LIST
+ "Severity", # SHORT_STRING, CONSTANT_LIST
+ "Software", # SHORT_STRING, DYNAMIC_LIST
+ "Software_Version", # SHORT_STRING
+ "Submit_Date", # DATE_TIME
+ "Submitter", # REFERENCE
+ "Symptoms", # MULTILINE_STRING, CONSTANT_LIST
+ "TCProcedure", # MULTILINE_STRING
+ "TestBlocking", # SHORT_STRING, CONSTANT_LIST
+ "TestCaseID", # INT
+ "TestcaseComment", # MULTILINE_STRING
+ "TimeFromSubmitToVerify", # SHORT_STRING
+ "TimeSubmitToResolve", # SHORT_STRING
+ "TimeToVerify", # SHORT_STRING
+ "Title_2", # SHORT_STRING
+ "VerifiedBy", # REFERENCE
+ "Verified_Date", # DATE_TIME
+ "Verified_In_HW_Version", # SHORT_STRING
+ "Verified_In_SW_Version", # SHORT_STRING
+ "VerifyNote", # MULTILINE_STRING
+ "Visibility", # SHORT_STRING, DYNAMIC_LIST
+ "customer", # REFERENCE_LIST
+ "customer_severity", # SHORT_STRING, CONSTANT_LIST
+ "old_id", # SHORT_STRING
+ );
+
+ # This describes the fields in the new Cont Defect record
+ our @new_Cont_defect_fields = (
+ "ActionNotes", # SHORT_STRING
+# Prod: <not defined>, TO: <not defined> -> Cont: Active_Deferred_Status
+ "Active_Deferred_Status", # SHORT_STRING, CONSTANT_LIST
+ "Advanced_Feature", # SHORT_STRING, DYNAMIC_LIST
+ "Assigned_Date", # DATE_TIME
+ "AttachmentsBRCM", # ATTACHMENT_LIST
+ "Audit_Log", # MULTILINE_STRING
+ "Board_Revision", # SHORT_STRING, DYNAMIC_LIST
+# Prod: NoteBRCMOnly, TO: NoteBRCMOnly -> Cont: Broadcom_Only_Note
+ "Broadcom_Only_Note", # MULTILINE_STRING
+# Prod: NoteBugReview, TO: NoteBugReview -> Cont: Bug_Review_Note
+ "Bug_Review_Note", # MULTILINE_STRING
+ "Category", # SHORT_STRING, CONSTANT_LIST
+ "Close_Date", # DATE_TIME
+ "CommitmentLevel", # SHORT_STRING, CONSTANT_LIST
+ "CommittedDate", # DATE_TIME
+ "CommittedToProject", # SHORT_STRING, DYNAMIC_LIST
+ "CustomerID", # SHORT_STRING
+ "DataPendingNote", # MULTILINE_STRING
+ "DeferredToChip", # SHORT_STRING
+ "DeferredToProject", # SHORT_STRING, DYNAMIC_LIST
+ "Description", # MULTILINE_STRING
+ "DoesNotVerifyNote", # MULTILINE_STRING
+ "Entry_Type", # SHORT_STRING, CONSTANT_LIST
+ "Est_Time_To_Fix", # SHORT_STRING
+ "Fixed_In_HW_Version", # SHORT_STRING
+ "Fixed_In_Project", # SHORT_STRING, DYNAMIC_LIST
+ "Fixed_In_SW_Version", # SHORT_STRING
+# Prod: Project (REFERENCE), TO: Project (REFERENCE) -> Cont: Found_In_Project (REFERENCE)
+ "Found_In_Project", # REFERENCE
+# Prod: <not defined>, TO: <not defined> -> Cont: Found_On_Gold
+ "Found_On_Gold", # SHORT_STRING, CONSTANT_LIST
+ "Gating_Item_HW", # SHORT_STRING, CONSTANT_LIST
+# Prod: GatingItem, TO: GatingItem -> Cont: Gating_Item_SW, Gating_Item_HW
+ "Gating_Item_SW", # SHORT_STRING, CONSTANT_LIST
+ "HUT", # SHORT_STRING, DYNAMIC_LIST
+ "HUT_Revision", # SHORT_STRING, DYNAMIC_LIST
+# Prod: Title, TO: Headline -> Cont: Headline
+ "Headline", # SHORT_STRING
+ "Issue_Classification", # SHORT_STRING, CONSTANT_LIST
+ "Keywords", # MULTILINE_STRING, CONSTANT_LIST
+# Prod: <not defined>, TO: <not defined> -> Cont: Newly_Introduce
+ "Newly_Introduce", # SHORT_STRING, CONSTANT_LIST
+ "Note_Entry", # MULTILINE_STRING
+ "Notes_Log", # MULTILINE_STRING
+ "OEMSubmitterName", # SHORT_STRING
+ "OS", # SHORT_STRING, DYNAMIC_LIST
+# Prod: <not defined>, TO: <not defined> -> Cont: Other_HUT
+ "Other_HUT", # MULTILINE_STRING
+ "Owner", # REFERENCE
+# Prod: <not defined>, TO: <not defined> -> Cont: PQATestCase
+ "PQATestCase", # SHORT_STRING, CONSTANT_LIST
+ "Priority", # SHORT_STRING, CONSTANT_LIST
+# Prod: ReportedBy, TO: ReportedBy -> Cont: Reported_By
+ "Reported_By", # REFERENCE
+ "Resolution", # SHORT_STRING, CONSTANT_LIST
+ "ResolveNote", # MULTILINE_STRING
+ "ResolvedBy", # REFERENCE
+ "Resolved_Date", # DATE_TIME
+# Prod: <not defined>, TO: <not defined> -> Cont: Root_Caused
+ "Root_Caused", # SHORT_STRING, CONSTANT_LIST
+# Prod: <not defined>, TO: <not defined> -> Cont: Root_Caused_Note
+ "Root_Caused_Note", # MULTILINE_STRING
+ "Service_Pack", # SHORT_STRING, DYNAMIC_LIST
+ "Severity", # SHORT_STRING, CONSTANT_LIST
+ "Software", # SHORT_STRING, DYNAMIC_LIST
+ "Software_Version", # SHORT_STRING
+ "Submit_Date", # DATE_TIME
+ "Submitter", # REFERENCE
+ "Symptoms", # MULTILINE_STRING, CONSTANT_LIST
+ "TCProcedure", # MULTILINE_STRING
+ "TestCaseID", # INT
+ "TestcaseComment", # MULTILINE_STRING
+ "TimeFromSubmitToVerify", # SHORT_STRING
+ "TimeSubmitToResolve", # SHORT_STRING
+ "TimeToVerify", # SHORT_STRING
+# Prod: Title_2, TO: Title_2 -> Cont: Title
+ "Title", # SHORT_STRING
+ "VerifiedBy", # REFERENCE
+ "Verified_Date", # DATE_TIME
+ "Verified_In_HW_Version", # SHORT_STRING
+ "Verified_In_SW_Version", # SHORT_STRING
+ "VerifyNote", # MULTILINE_STRING
+# Prod: <not defined>, TO: <not defined> -> Cont: <added>
+ "Visibility", # SHORT_STRING, DYNAMIC_LIST
+# Prod: <not defined>, TO: <not defined> -> Cont: WorkAroundNote
+ "WorkAroundNote", # MULTILINE_STRING
+ "customer", # REFERENCE_LIST
+ "customer_severity", # SHORT_STRING, CONSTANT_LIST
+ "old_id", # SHORT_STRING
+# Prod: <not defined>, TO: Found_In_Project -> Cont: <Deleted>
+# "Found_In_Project", # SHORT_STRING, DYNAMIC_LIST
+# Deleted fields:
+# "HUT_Version", # SHORT_STRING, DYNAMIC_LIST
+# "Open_Close_Status", # SHORT_STRING, CONSTANT_LIST
+# "PendingHWSWReleases", # INT
+# "SQATestCase", # SHORT_STRING, CONSTANT_LIST
+# "TestBlocking", # SHORT_STRING, CONSTANT_LIST
+ );
+
+ # Customer and Project records appear in both instances of the old
+ # databases as well as the new Cont database and have not changed.
+ our @customer_fields = (
+ "Name", # SHORT_STRING
+ "Phone", # SHORT_STRING
+ "Fax", # SHORT_STRING
+ "Email", # SHORT_STRING
+ "CallTrackingID", # SHORT_STRING
+ "Description", # MULTILINE_STRING
+ "Company", # SHORT_STRING
+ "Attachment", # ATTACHMENT_LIST
+ );
+
+ our @project_fields = (
+ "Name", # SHORT_STRING
+ "Description", # MULTILINE_STRING
+ );
+
+ # Collect bad characters
+ our %bad_chars;
+
+ ## Internal variables ##
+ my $login = "<username>";
+ my $password = "<password>";
+ my $db_name;
+
+ my $id;
+
+ my $nbr_chars = 40;
+ my $half = $nbr_chars / 2;
+
+ # Derived from http://hotwired.lycos.com/webmonkey/reference/special_characters/
+ my %char_map = (
+ 128 => "€",
+ 129 => "",
+ 130 => "‚",
+ 131 => "ƒ",
+ 132 => "„",
+ 133 => "…",
+ 134 => "†",
+ 135 => "‡",
+ 136 => "ˆ",
+ 137 => "‰",
+ 138 => "Š",
+ 139 => "‹",
+ 140 => "Œ",
+ 141 => "",
+ 142 => "Ž",
+ 143 => "",
+ 144 => "",
+ 145 => "'", # Signal "smart quote" left
+ 146 => "'", # Signal "smart quote" right
+ 147 => "\"", # Double "smart quote" left
+ 148 => "\"", # Double "smart quote" right
+ 149 => "•",
+ 150 => "–", # En dash
+ 151 => "—", # Em dash
+ 152 => "˜",
+ 153 => "™",
+ 154 => "š",
+ 155 => "›",
+ 156 => "œ",
+ 157 => "",
+ 158 => "ž",
+ 159 => "Ÿ",
+ 160 => " ", # Nonbreaking space
+ 161 => "¡", # Inverted exclamation (¡)
+ 162 => "¢", # Cent sign (¢)
+ 163 => "£", # Pound sterling (£)
+ 164 => "¤", # General currency sign (¤)
+ 165 => "¥", # Yen sign (¥)
+ 166 => "&brkbar;", # Broken vertical bar (¦)
+ 167 => "§", # Section sign (§)
+ 168 => "¨", # Umlaut (¨)
+ 169 => "©", # Copyright (©)
+ 170 => "ª", # Feminine ordinal (ª)
+ 171 => "«", # Left angle quote («)
+ 172 => "¬", # Not sign (¬)
+ 173 => "­", # Soft hyphen
+ 174 => "®", # Registered trademark (®)
+ 175 => "¯", # Macron accent (¯)
+ 176 => "°", # Degree sign (°)
+ 177 => "±", # Plus or minus (±)
+ 178 => "²", # Superscript two (²)
+ 179 => "³", # Superscript three (³)
+ 180 => "´", # Acute accent (´)
+ 181 => "µ", # Micro sign (µ)
+ 182 => "¶", # Paragraph sign (¶)
+ 183 => "·", # Middle dot (·)
+ 184 => "¸", # Cedilla (¸)
+ 185 => "¹", # Superscript one (¹)
+ 186 => "º", # Masculine ordinal (º)
+ 187 => "»", # Right angle quote (»)
+ 188 => "¼", # One-forth (¼)
+ 189 => "½", # One-half (½)
+ 190 => "&frac24;", # Three-fourths (¾)
+ 191 => "¿", # Inverted question mark (¿)
+ 192 => "À", # Uppercase A, grave accent (À)
+ 193 => "Á", # Uppercase A, acute accent (Á)
+ 194 => "Â", # Uppercase A, circumflex accent (Â)
+ 195 => "Ã", # Uppercase A, tilde (Ã)
+ 196 => "Ä", # Uppercase A, umlaut (Ä)
+ 197 => "Å", # Uppercase A, ring (Å)
+ 198 => "Æ", # Uppercase AE (Æ)
+ 199 => "Ç", # Uppercase C, cedilla (Ç)
+ 200 => "È", # Uppercase E, grave accent (È)
+ 201 => "É", # Uppercase E, acute accent (É)
+ 202 => "Ê", # Uppercase E, circumflex accent (Ê)
+ 203 => "Ë", # Uppercase E, umlaut (Ë)
+ 204 => "Ì", # Uppercase I, grave accent (Ì)
+ 205 => "Í", # Uppercase I, acute accent (Í)
+ 206 => "Î", # Uppercase I, circumflex accent (Î)
+ 207 => "Ï", # Uppercase I, umlaut (Ï)
+ 208 => "Ð", # Uppercase Eth, Icelandic (Ð)
+ 209 => "Ñ", # Uppercase N, tilde (Ñ)
+ 210 => "Ò", # Uppercase O, grave accent (Ò)
+ 211 => "Ó", # Uppercase O, acute accent (Ó)
+ 212 => "Ô", # Uppercase O, circumflex accent (Ô)
+ 213 => "Õ", # Uppercase O, tilde (Õ)
+ 214 => "Ö", # Uppercase O, umlaut (Ö)
+ 215 => "×", # Muliplication sign (×)
+ 216 => "Ø", # Uppercase O, slash (Ø)
+ 217 => "Ù", # Uppercase U, grave accent (Ù)
+ 218 => "Ú", # Uppercase U, acute accent (Ú)
+ 219 => "Û", # Uppercase U, circumflex accent (Û)
+ 220 => "Ü", # Uppercase U, umlaut (Ü)
+ 221 => "Ý", # Uppercase Y, acute accent (Ý)
+ 222 => "Þ", # Uppercase THORN, Icelandic (Þ)
+ 223 => "ß", # Lowercase sharps, German (ß)
+ 224 => "à", # Lowercase a, grave accent (à)
+ 225 => "á", # Lowercase a, acute accent (á)
+ 226 => "â", # Lowercase a, circumflex acirc (â)
+ 227 => "ã", # Lowercase a, tilde (ã)
+ 228 => "ä", # Lowercase a, umlaut (ä)
+ 229 => "å", # Lowercase a, ring (å)
+ 230 => "æ", # Lowercase ae (æ)
+ 231 => "ç", # Lowercase c, cedilla (ç)
+ 232 => "è", # Lowercase e, grave accent (è)
+ 233 => "é", # Lowercase e, acute accent (é)
+ 234 => "ê", # Lowercase e, circumflex accent (ê)
+ 235 => "ë", # Lowercase e, umlaut (ë)
+ 236 => "ì", # Lowercase i, grave accent (ì)
+ 237 => "í", # Lowercase i, acute accent (í)
+ 238 => "î", # Lowercase i, circumflex accent (î)
+ 239 => "ï", # Lowercase i, umlaut (ï)
+ 240 => "ð", # Lowercase eth, Icelandic (ð)
+ 241 => "ñ", # Lowercase n, tilde (ñ)
+ 242 => "ò", # Lowercase o, grave accent (ò)
+ 243 => "ó", # Lowercase o, acute accent (ó)
+ 244 => "ô", # Lowercase o, circumflex accent (ô)
+ 245 => "õ", # Lowercase o, tilde (õ)
+ 246 => "ö", # Lowercase o, umlaut (ö)
+ 247 => "÷", # Division sign (÷)
+ 248 => "ø", # Lowercase o, slash (ø)
+ 249 => "ù", # Lowercase u, grave accent (ù)
+ 250 => "ú", # Lowercase u, acute accent (ú)
+ 251 => "û", # Lowercase u, circumflex accent (û)
+ 252 => "ü", # Lowercase u, umlaut (ü)
+ 253 => "ý", # Lowercase y, acute accent (ý)
+ 254 => "þ", # Lowercase thorn, Icelandic (þ)
+ 255 => "ÿ", # Lowercase y, umlaut (ÿ)
+ );
+
+ ## Exported functions ##
+ # Add a value to a field's dynamic list
+ sub AddToFieldChoiceList {
+ my $session = shift;
+ my $entity = shift;
+ my $dynamic_list = shift;
+ my $name = shift;
+ my $value = shift;
+
+ return if $value eq "";
+
+ # It seems that adding the entry to the dynamic list is not enough.
+ # I believe that Clearquest caches entries on a dynamic list so we
+ # need to tell Clearquest about this new entry.
+ my $add_value = 1;
+ my @values = @{$entity->GetFieldChoiceList ($name)};
+
+ # Ack! Seems now we have values like Service_Pack = "1.A" and
+ # Service_Pack = "1.a", which translate to the same value as far
+ # as a dynamic list is concerned, so we'll do the comparison
+ # ignoring case... Additionally there can be regex meta characters
+ # in the value so we'll need to protect from that.
+ foreach (@values) {
+ if ("\L$value\E" eq "\L$_\E") {
+ $add_value = 0;
+ last;
+ } # if
+ } # foreach
+
+ if ($add_value) {
+ push @values, $value;
+
+ $entity->SetFieldChoiceList ($name, \@values);
+ } # if
+
+ # Get the current values, if any
+ @values = @{$session->GetListMembers ($dynamic_list)};
+
+ # Search to see if the item is already on the list
+ foreach (@values) {
+ return if ("\L$value\E" eq "\L$_\E");
+ } # if
+
+ $session->AddListMember ($dynamic_list, $value);
+
+ push @values, $value;
+
+ $session->SetListMembers ($dynamic_list, \@values);
+ } # AddToDynamicList
+
+ # TO: defect: Found_In_Project is currently a dynamic list but is
+ # going to Cont: defect: Found_In_Project which is a reference to
+ # Cont: Project. So we need to dynamically add those.
+ sub AddToProject {
+ my $log = shift;
+ my $to = shift;
+ my $project = shift;
+
+ if (ProjectExists $to, $project) {
+ return;
+ } # if
+
+ my $entity = $to->BuildEntity ("Project");
+
+ $entity->SetFieldValue ("name", $project);
+
+ # Call the Validate method
+ my $errmsg = $entity->Validate;
+
+ $log->err ("Unable to validate Project record: $project:\n$errmsg", 1) if $errmsg ne "";
+
+ # Post record to database
+ $entity->Commit if $errmsg eq "";
+ } # AddToProject
+
+ sub CheckField {
+ my $log = shift;
+ my $db_name = shift;
+ my $record_name = shift;
+ my $id = shift;
+ my $field_name = shift;
+ my $str = shift;
+
+ return $str if length $str eq 0; # Ignore empty strings
+
+ if ($str =~ /[^\t\n\r -\177]/) {
+ for (my $x = 0; $x < length $str; $x++) {
+ my $y = substr $str, $x, 1;
+ if ($y =~ /[^\t\n\r -\177]/) {
+ my $o = ord ($y);
+ display "At char #$x found \"$y\" ($o)";
+ my $s = substr $str, $x - 20, 40;
+ display "\"$s\"";
+ } # if
+ } # for
+ error "$field_name match", 1;
+ } # if
+
+ for (my $i = 0; $i < length $str; $i++) {
+ my $ord = ord (substr $str, $i, 1);
+
+ if ($ord < 0 or $ord > 127) {
+ # $id is undefined at this point...
+ $log->msg ("$db_name:$record_name:$id:$field_name:$i");
+ $log->msg ("Old Contents:\n$str");
+ $str = FixChar ($str, $i);
+ $log->msg ("New Contents:\n$str");
+ } # if
+ } # foreach
+
+ return $str;
+ } # CheckField
+
+ sub CheckRecord {
+ my $log = shift;
+ my $session = shift;
+ my $id_name = shift;
+ my $record_name = shift;
+ my $id = shift;
+ my @fields = @_;
+
+ my $result;
+
+ if (defined $id) {
+ $result = GetDefectRecord $log, $session, $record_name, $id;
+ } else {
+ $result = GetAllDefectRecords $log, $session, $record_name;
+ } # if
+
+ while ($result->MoveNext == $CQPerlExt::CQ_SUCCESS) {
+ # GetEntity by using $id
+ $id = $result->GetColumnValue (1);
+ my $entity = $session->GetEntity ($record_name, $id);
+
+ $log->msg ($id);
+
+ foreach (@fields) {
+ my $name = $_;
+ my $value = $entity->GetFieldValue ($name)->GetValue;
+
+ $value = CheckField $log, $db_name, $record_name, $id, $name, $value;
+ } # for
+ } # for
+ } # CheckRecord
+
+ sub DeleteDynamicLists {
+ my $log = shift;
+ my $from = shift;
+
+ my @dynamic_lists = (
+ "Advanced_Feature",
+ "Board_Revision",
+ "HUT",
+ "HUT_Revision",
+ "OS",
+ "OS_Service_Pack",
+ "Other_HUT",
+ "Project",
+ "Reported_By",
+ "Software",
+ "Visibility",
+ );
+
+ $log->msg ("Clearing dynamic lists...");
+
+ foreach my $name (@dynamic_lists) {
+ my @values = @{$from->GetListMembers ($name)};
+
+ foreach my $value (@values) {
+ $from->DeleteListMember ($name, $value);
+ } # foreach
+ } # foreach
+ } # DeleteDynamicLists
+
+ sub DeleteRecords {
+ my $log = shift;
+ my $from = shift;
+ my $record_name = shift;
+
+ # Create a query for $record_name
+ my $query = $from->BuildQuery ($record_name);
+
+ $query->BuildField ("dbid");
+
+ # Build the result set
+ my $result = $from->BuildResultSet ($query);
+
+ # Execute the query
+ my $record_count = $result->ExecuteAndCountRecords;
+
+ $log->msg ("Found $record_count $record_name records to delete...");
+
+ return if $record_count eq 0;
+
+ my $old_bufffer_status = $|;
+ $| = 1; # Turn off buffering
+
+ # Now for each record returned by the query...
+ while ($result->MoveNext == 1) {
+ my $id = $result->GetColumnValue (1);
+
+ # Get entity
+ my $entity = $from->GetEntityByDbId ($record_name, $id);
+
+ # Delete it
+ my $errmsg = $from->DeleteEntity ($entity, "delete");
+
+ verbose ".", undef, "nolf";
+ $log->err ("\n$errmsg\n") if $errmsg ne "";
+ } # while
+
+ verbose "";
+
+ $| = $old_bufffer_status; # Restore buffering
+ } # DeleteRecords
+
+ sub EndSession {
+ my $session = shift;
+
+ CQSession::Unbuild $session;
+ } # EndSession
+
+ sub GetAllDefectRecords {
+ my $log = shift;
+ my $from = shift;
+ my $record_name = shift;
+
+ # Create a query for the record
+ my $query = $from->BuildQuery ($record_name);
+
+ # Add only dbid to the query. We'll retrieve the whole entity record later.
+ $query->BuildField ("id");
+
+ # Build the result set
+ my $result = $from->BuildResultSet ($query);
+
+ # Execute the query
+ my $record_count = $result->ExecuteAndCountRecords;
+
+ $log->msg ("Found $record_count $record_name records...");
+
+ if ($record_count eq 0) {
+ return undef;
+ } else {
+ return $result;
+ } # if
+ } # GetAllDefectRecords
+
+ sub GetDefectRecord {
+ my $log = shift;
+ my $from = shift;
+ my $record_name = shift;
+ my $id = shift;
+
+ my $query = $from->BuildQuery ($record_name);
+ my $filter = $query->BuildFilterOperator ($CQPerlExt::AD_BOOL_OP_AND);
+
+ $query->BuildField ("id");
+
+ # BuildFilter requires an array reference
+ my @ids;
+ push @ids, $id;
+ $filter->BuildFilter ("id", $CQPerlExt::CQ_COMP_OP_EQ, \@ids);
+
+ my $result = $from->BuildResultSet ($query);
+ my $record_count = $result->ExecuteAndCountRecords;
+
+ $log->msg ("Found $record_count $record_name record...");
+
+ if ($record_count eq 0) {
+ return undef;
+ } else {
+ return $result;
+ } # if
+ } # GetDefectRecord
+
+ sub ProjectExists {
+ my $to = shift;
+ my $project = shift;
+
+ my $query = $to->BuildQuery ("Project");
+
+ my $filter = $query->BuildFilterOperator ($CQPerlExt::AD_BOOL_OP_AND);
+
+ $query->BuildField ("name");
+
+ # BuildFilter requires an array reference
+ my @projects;
+ push @projects, $project;
+ $filter->BuildFilter ("name", $CQPerlExt::CQ_COMP_OP_EQ, \@projects);
+
+ my $result = $to->BuildResultSet ($query);
+
+ my $record_count = $result->ExecuteAndCountRecords;
+
+ return $record_count;
+ } # ProjectExists
+
+ sub StartSession {
+ $db_name = shift;
+ $masterdb = shift;
+
+ my $session = CQPerlExt::CQSession_Build ();
+
+ $masterdb = "" if !defined $masterdb;
+
+ $session->UserLogon ($login, $password, $db_name, $masterdb);
+
+ return $session;
+ } # StartSession
+
+ sub TransferAttachments {
+ my $log = shift;
+ my $from = shift;
+ my $to = shift;
+
+ my @files_created;
+
+ my $from_attachment_fields = $from->GetAttachmentFields;
+
+ for (my $i = 0; $i < $from_attachment_fields->Count; $i++) {
+ my $from_attachment_field = $from_attachment_fields->Item ($i);
+ my $field_name = $from_attachment_field->GetFieldName;
+
+ # At this point we don't have any info about whether we are
+ # coming from Prod or TO, however, there are the following fields:
+ #
+ # TO Prod Cont
+ # ----------------------- ----------------------- ----------------
+ # Attachments Attachments Attachments
+ # AttachmentsBRCM AttachmentBRCM AttachmentsBRCM
+ #
+ # You may notice that Prod: AttachmentBRCM is missing the "s".
+ # Therefore:
+ $field_name = "AttachmentsBRCM" if $field_name eq "AttachmentBRCM";
+
+ my $from_attachments = $from_attachment_field->GetAttachments;
+
+ my $filename_suffix = 0;
+
+ for (my $j = 0; $j < $from_attachments->Count; $j++) {
+ my $from_attachment = $from_attachments->Item ($j);
+ my $description = $from_attachment->GetDescription;
+ my $filename = $from_attachment->GetFileName;
+
+ debug "Processing attachment #$j: $filename: $description";
+
+ # Extract the attached file to the file named attachment;
+ # Argh! Sometimes people attach files with the same filename!
+ # This works because filename is not really used except when
+ # you initially load the file. So the user could have, for
+ # example, captured say a logfile.txt, attached it,
+ # regenerated a new logfile.txt and attached it! This is
+ # perfectly acceptable since logfile.txt is copied into the
+ # database. However, when we extract it here we just use
+ # $filename. The result is that the second logfile.txt
+ # overwrites the first logfile.txt! We need to check for
+ # clashes (only a handful of them) and generate a new
+ # filename.
+ if (-f $filename) {
+ $filename_suffix++;
+ $filename = "$filename.$filename_suffix";
+ } # if
+
+ $from_attachment->Load ($filename);
+
+ $to->AddAttachmentFieldValue ($field_name, $filename, $description);
+
+ push @files_created, $filename;
+ } # for
+ } # for
+
+ return @files_created;
+ } # TransferAttachments
+
+ sub TransferHistory {
+ my $from_entity = shift;
+ my $to_entity = shift;
+ my $filename = shift;
+
+ my $history_fields = $from_entity->GetHistoryFields;
+ my $nbr_history_fields = $history_fields->Count;
+
+ return if $nbr_history_fields eq 0;
+
+ for (my $i = 0; $i < $nbr_history_fields; $i++) {
+ my $histories = $history_fields->Item ($i)->GetHistories;
+ my $nbr_histories = $histories->Count;
+
+ return if $nbr_histories eq 0;
+
+ # Write out history to History.txt
+ open HISTORY, ">$filename"
+ or error "Unable to open $filename", 1;
+
+ print HISTORY "Previous History:\n";
+ print HISTORY "-----------------\n";
+
+ for (my $j = 0; $j < $nbr_histories; $j++) {
+ my $history_item = $histories->Item ($j);
+ my $history_value = $history_item->GetValue;
+
+ # Remove dbid
+ $history_value =~ /\S*\s*(.*$)/;
+ print HISTORY "$1\n";
+ } # for
+
+ close HISTORY;
+ } # for
+
+ # Add previous history as an AttachmentsBRCM
+ $to_entity->AddAttachmentFieldValue ("AttachmentsBRCM", $filename, "Previous history");
+ } # TransferHistory
+
+ sub TransferRecords {
+ my $log = shift;
+ my $from = shift;
+ my $to = shift;
+ my $dbname = shift;
+ my $record_name = shift;
+ my @field_list = @_;
+
+ # Create a query for the record
+ my $query = $from->BuildQuery ($record_name);
+
+ # Always get the $id_name field
+ $query->BuildField ("dbid");
+
+ # Add all of @field_list to the query
+ foreach (@field_list) {
+ $query->BuildField ($_);
+ } # foreach
+
+ # Build the result set
+ my $result = $from->BuildResultSet ($query);
+
+ # Execute the query
+ my $record_count = $result->ExecuteAndCountRecords;
+
+ verbose "Found $record_count $record_name records to merge...";
+
+ return if $record_count eq 0;
+
+ my $old_bufffer_status = $|;
+ $| = 1; # Turn off buffering
+
+ # Now for each record returned by the query...
+ while ($result->MoveNext == 1) {
+ # Create a new entity
+ my $entity = $to->BuildEntity ($record_name);
+
+ my $cols = $result->GetNumberOfColumns;
+
+ my $id = $result->GetColumnValue (1);
+
+ # Get the fields...
+ for (my $i = 2; $i <= $cols; $i++) {
+ my $name = $result->GetColumnLabel ($i);
+ my $value = $result->GetColumnValue ($i);
+
+ # Check field for non US ASCII characters and fix them
+ $value = CheckField $dbname, $record_name, $id, $name, $value;
+
+ # Set the field's value
+ $entity->SetFieldValue ($name, $value);
+ } # for
+
+ # Call the Validate method
+ my $errmsg = $entity->Validate;
+
+ $log->err ("Unable to validate $record_name record:\n$errmsg", 1) if $errmsg ne "";
+
+ # Post record to database
+ $entity->Commit;
+ verbose ".", undef, "nolf";
+ } # while
+
+ $| = $old_bufffer_status; # Restore buffering
+ verbose " done";
+ } # TransferRecords
+
+ # Internal functions
+ sub DisplayWord {
+ my $str = shift;
+ my $start = shift;
+
+ my $ord = ord (substr $str, $start, 1);
+ my $end = $start;
+ my $orig_start = $start;
+
+ # Let's just show a small subset of characters
+ if (length $str < $nbr_chars) {
+ $end = length $str;
+ $start = 0;
+ } elsif (($start + $half) > length $str) {
+ $end = length $str;
+ my $right = length $str - $start;
+ if (($start - ($half + ($half - $right))) lt 0) {
+ $start = 0;
+ } else {
+ $start = $start - ($half + $right);
+ } # if
+ } elsif (($start - $half) < 0) {
+ $start = 0;
+ if ($start + ($half + $start) gt length $str) {
+ $end = length $str;
+ } else {
+ $end = $start + ($half + $start);
+ } # if
+ } else {
+ $end = $start + $half;
+ $start = $start - $half;
+ } # if
+
+ my $word = substr $str, $start, $end - $start;
+
+ debug "\t@ pos $orig_start ($ord)\n\t\"$word\"\n";
+ } # DisplayWord
+
+ sub FixChar {
+ my $str = shift;
+ my $pos = shift;
+
+ my $ord = ord (substr $str, $pos, 1);
+
+ error "Unknown character found ($ord) \"" . substr ($str, $pos, 1) . "\"", 1
+ if (!defined $char_map {$ord});
+
+ if ($debug eq "yes") {
+ debug "Before:\n";
+ DisplayWord $str, $pos;
+ } # if
+
+ substr ($str, $pos, 1) = $char_map {$ord};
+
+ if ($debug eq "yes") {
+ debug "After:\n";
+ DisplayWord $str, $pos;
+ } # if
+
+ return $str;
+ } # FixChar
+
+1;
--- /dev/null
+#!cqperl
+use strict;
+use warnings;
+use CQPerlExt;
+use File::Spec;
+
+our ($me, $SEPARATOR);
+
+my ($abs_path, $lib_path);
+
+BEGIN {
+ # Extract relative path and basename from script name.
+ $0 =~ /(.*)[\/\\](.*)/;
+
+ $abs_path = (!defined $1) ? "." : File::Spec->rel2abs ($1);
+ $me = (!defined $2) ? $0 : $2;
+ $me =~ s/\.pl$//;
+
+ # Define the path SEPARATOR
+ $SEPARATOR = ($^O =~ /MSWin/) ? "\\" : "/";
+
+ # Setup paths
+ $lib_path = "$abs_path" . $SEPARATOR . ".." . $SEPARATOR . "lib";
+
+ # Add the appropriate path to our modules to @INC array.
+ unshift (@INC, "$abs_path");
+ unshift (@INC, "$lib_path");
+} # BEGIN
+
+use PQA;
+use Display;
+
+sub TotalAttachment {
+ my $log = shift;
+ my $id = shift;
+ my $from = shift;
+
+ my $attachments_size = 0;
+
+ my $from_attachment_fields = $from->GetAttachmentFields;
+
+ for (my $i = 0; $i < $from_attachment_fields->Count; $i++) {
+ my $from_attachment_field = $from_attachment_fields->Item ($i);
+ my $field_name = $from_attachment_field->GetFieldName;
+
+ # Process attachments in this attachment field
+ my $from_attachments = $from_attachment_field->GetAttachments;
+
+ for (my $j = 0; $j < $from_attachments->Count; $j++) {
+ my $from_attachment = $from_attachments->Item ($j);
+ my $description = $from_attachment->GetDescription;
+ my $filename = $from_attachment->GetFileName;
+ my $size = $from_attachment->GetFileSize;
+
+ next if $filename eq "history.txt";
+ $log->msg ("$id,$filename,$size");
+ $attachments_size += $size;
+ } # for
+ } # for
+
+ $log->msg ("$id,Total attachment size,$attachments_size") if $attachments_size ne 0;
+
+ return $attachments_size;
+} # TotalAttachment
+
+my $log = Logger->new (path => ".");
+
+# Open databases
+my $record_name = "defect";
+
+my $connection = "2005.02.00";
+my $cont = StartSession "Cont", $connection;
+
+$connection = "2003.06.00";
+my $teton = StartSession "TO", $connection;
+my $prod = StartSession "Prod", $connection;
+
+my $result = GetAllDefectRecords $log, $cont, $record_name;
+
+my $grand_total_old = 0;
+my $grand_total_new = 0;
+
+while ($result->MoveNext == $CQPerlExt::CQ_SUCCESS) {
+ # GetEntity by using $id
+ my $id = $result->GetColumnValue (1);
+ my $from = $cont->GetEntity ($record_name, $id);
+
+ my $new_size = TotalAttachment $log, $id, $from;
+
+ my $old_id = $from->GetFieldValue ("old_id")->GetValue;
+
+ my $to;
+
+ if ($old_id =~ /^TO/) {
+ $to = $teton->GetEntity ($record_name, $old_id);
+ } elsif ($old_id =~ /^Prod/) {
+ $to = $prod->GetEntity ($record_name, $old_id);
+ } else {
+ error "Old_id is not set! $old_id";
+ } # if
+
+ my $old_size = TotalAttachment $log, $id, $to;
+
+ $grand_total_old += $old_size;
+ $grand_total_new += $new_size;
+
+ if ($new_size gt $old_size) {
+ display "$id:$new_size > $old_id:$old_size";
+ } elsif ($new_size lt $old_size) {
+ display "$id:$new_size < $old_id:$old_size";
+# } else {
+# display "$id:$new_size = $old_id:$old_size";
+ } # if
+
+} # while
+
+display "Grand total (old): $grand_total_old";
+display "Grand total (new): $grand_total_new";
+
+EndSession $cont;
+EndSession $teton;
+EndSession $prod;
--- /dev/null
+#!/usr/bin/perl
+use strict;
+use warnings;
+
+=pod
+
+=head1 NAME $RCSfile: convertList.pl,v $
+
+This script allows you to convert a Clearquest Dynamic List to a stateless
+table. You must specify what the dynamic list name is, the stateless table name
+you wish to convert it to and the field name that serves as the key.
+
+This script will note duplicate and skip them. It will not remove the dynamic
+list.
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 2.2 $
+
+=item Created:
+
+Mon Oct 24 16:19:15 PDT 2011
+
+=item Modified:
+
+$Date: 2012/12/18 19:44:10 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage: convertList.pl -list <list> -table <table> -field <field>
+ [-u|sage] [-v|erbose] [-d|ebug]
+ [-username <username>] [-password <password>]
+ [-database <database>] [-dbset <dbset>]
+ [-module] [-server <server>] [-port <port>]
+
+ Where:
+ -l|ist: Dynamic list name to convert
+ -t|able: Name of the stateless table to convert the dynamic
+ list to
+ -field: Name of the field to fill in with the values from
+ -list
+
+ -usa|ge: Displays usage
+ -v|erbose: Be verbose
+ -de|bug: Output debug messages
+
+ -use|rname: Username to open database with (Default: from config file)
+ -p|assword: Password to open database with (Default: from config file)
+ -da|tabase: Database to open (Default: from config file)
+ -db|set: Database Set to use (Default: from config file)
+ -m|odule: Type of Clearquest module to use. Must be one of 'api',
+ 'client', or 'rest'. The 'api' module can only be used if
+ Clearquest is installed locally. The 'client' module can
+ only be successful if a corresponding server is running. And
+ the 'rest' module can only be used if a CQ Web server has
+ been set up and configured (Default: rest)
+ -s|erver: For module = client or rest this is the name of the server
+ that will be providing the service
+ -p|ort: For module = client, this is the point on the server to talk
+ through.
+
+=head1 Options
+
+Options are keep in the cq.conf file in etc. They specify the default options
+listed below. Or you can export the option name to the env(1) to override the
+defaults in cq.conf. Finally you can programmatically set the options when you
+call new by passing in a %parms hash. To specify the %parms hash key remove the
+CQ_ portion and lc the rest.
+
+=for html <blockquote>
+
+=over
+
+=item CQ_WEBHOST
+
+The web host to contact with leading http://
+
+=item CQ_DATABASE
+
+Name of database to connect to (Default: from config file)
+
+=item CQ_USERNAME
+
+User name to connect as (Default: from config file)
+
+=item CQ_PASSWORD
+
+Password for CQ_USERNAME
+
+=item CQ_DBSET
+
+Database Set name (Default: from config file)
+
+=item CQ_SERVER
+
+Clearquest::Server name to connect to (Default: from config file)
+
+=item CQ_PORT
+
+Clearquest::Server port to connect to (Default: from config file)
+
+=back
+
+=cut
+
+use FindBin;
+use Getopt::Long;
+
+use lib "$FindBin::Bin/../lib";
+
+use Clearquest;
+use Display;
+use Logger;
+use TimeUtils;
+use Utils;
+
+my $VERSION = '$Revision: 2.2 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+my (%opts, $cq, $log, %totals);
+
+## Main
+local $| = 1;
+
+my $startTime = time;
+
+GetOptions (
+ \%opts,
+ usage => sub { Usage },
+ verbose => sub { set_verbose },
+ debug => sub { set_debug },
+ 'module=s',
+ 'username=s',
+ 'database=s',
+ 'password=s',
+ 'dbset=s',
+ 'list=s',
+ 'table=s',
+ 'field=s',
+ 'server=s',
+ 'port=i',
+) || Usage;
+
+$log = Logger->new;
+
+$log->msg ("$FindBin::Script v$VERSION");
+
+Usage 'Must specify -list' unless $opts{list};
+Usage 'Must specify -table' unless $opts{table};
+Usage 'Must specify -field' unless $opts{field};
+
+# Translate any options to ones that the lib understands
+$opts{CQ_USERNAME} = delete $opts{username};
+$opts{CQ_PASSWORD} = delete $opts{password};
+$opts{CQ_DATABASE} = delete $opts{database};
+$opts{CQ_DBSET} = delete $opts{dbset};
+$opts{CQ_SERVER} = delete $opts{server};
+$opts{CQ_PORT} = delete $opts{port};
+$opts{CQ_MODULE} = delete $opts{module};
+
+$cq = Clearquest->new (%opts);
+
+my $connection = $cq->username . '@' . $cq->database . '/' . $cq->dbset;
+ $connection .= ' (Server: ' . $cq->host . ':' . $cq->port . ')'
+ if ref $cq eq 'Clearquest::Client';
+
+$log->msg ("Connecting to $connection...", 1);
+
+$cq->connect;
+
+$log->msg (' connected');
+
+foreach ($cq->getDynamicList ($opts{list})) {
+ verbose_nolf '.';
+
+ $totals{Processed}++;
+
+ my $errmsg = $cq->add ($opts{table}, ($opts{field} => $_));
+
+ if ($errmsg ne '') {
+ if ($errmsg =~ /duplicate entries in the database/ or
+ $errmsg =~ /Record with same displayname exists/) {
+ $totals{Duplicates}++;
+ } else {
+ $log->err ($errmsg);
+ } # if
+ } else {
+ $totals{Added}++;
+ } # if
+} # foreach
+
+$totals{Errors} = $log->errors;
+
+error 'Errors occured - check ' . $log->fullname . ' for more info'
+ if $totals{Errors};
+
+Stats \%totals, $log;
+
+display_duration $startTime, $log;
+
+$cq->disconnect;
+
+exit $log->errors;
--- /dev/null
+#!/usr/bin/perl
+use strict;
+use warnings;
+
+=pod
+
+=pod
+
+=head1 NAME $RCSfile: cqaction.pl,v $
+
+Clearquest Action
+
+This script attempt to apply an action to a statefull Clearquest record.
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 2.2 $
+
+=item Created:
+
+Mon Jul 30 12:05:45 PDT 2012
+
+=item Modified:
+
+$Date: 2012/12/18 19:44:10 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage: cqaction.pl [-u|sage] [-v|erbose] [-d|ebug]
+ [-username <username>] [-password <password>]
+ [-database <dbname>] [-dbset <dbset>]
+ [-record <record>] [-key <key>]
+ [-action <action>]
+ [-module] [-server <server>] [-port <port>]
+
+
+ Where:
+ -u|sage: Displays usage
+ -v|erbose: Be verbose
+ -de|bug: Output debug messages
+
+ -record: Record to apply the action to (Default: Defect)
+ -key: Key to locate the record with (Note that if you supply simply
+ a number (e.g. 1234) then we will expand that with leading
+ zeroes to the length of 8 digits and prepend the database name)
+ -action: Action to apply (Default: Modify)
+
+ -use|rname: Username to open database with (Default: from config file)
+ -p|assword: Password to open database with (Default: from config file)
+ -da|tabase: Database to open (Default: from config file)
+ -db|set: Database Set to use (Default: from config file)
+ -m|odule: Type of Clearquest module to use. Must be one of 'api',
+ 'client', or 'rest'. The 'api' module can only be used if
+ Clearquest is installed locally. The 'client' module can
+ only be successful if a corresponding server is running. And
+ the 'rest' module can only be used if a CQ Web server has
+ been set up and configured (Default: rest)
+ -s|erver: For module = client or rest this is the name of the server
+ that will be providing the service
+ -p|ort: For module = client, this is the point on the server to talk
+ through.
+
+=head1 Options
+
+Options are keep in the cq.conf file in etc. They specify the default options
+listed below. Or you can export the option name to the env(1) to override the
+defaults in cq.conf. Finally you can programmatically set the options when you
+call new by passing in a %parms hash. To specify the %parms hash key remove the
+CQ_ portion and lc the rest.
+
+=for html <blockquote>
+
+=over
+
+=item CQ_WEBHOST
+
+The web host to contact with leading http://
+
+=item CQ_DATABASE
+
+Name of database to connect to (Default: from config file)
+
+=item CQ_USERNAME
+
+User name to connect as (Default: from config file)
+
+=item CQ_PASSWORD
+
+Password for CQ_USERNAME
+
+=item CQ_DBSET
+
+Database Set name (Default: from config file)
+
+=item CQ_SERVER
+
+Clearquest::Server name to connect to (Default: from config file)
+
+=item CQ_PORT
+
+Clearquest::Server port to connect to (Default: from config file)
+
+=back
+
+=head1 Modifying fields while changing state
+
+If you need to modify fields while changing state then feed them to this
+script's stdin in the form of:
+
+ <field>=<value>
+
+B<Note:> Don't forget that you will be prompted field=value and you'll need
+to signal that you have entered all of the field/value pairs you intended with
+Ctrl-D (or Ctrl-Z on Windows). You can short circut this by feeding something
+like /dev/null to stdin like so:
+
+ $ cat /dev/null > cqaction.pl <parms>
+
+=cut
+
+use FindBin;
+use Getopt::Long;
+
+use lib "$FindBin::Bin/../lib";
+
+use Display;
+use Utils;
+
+my %opts;
+
+sub getFields () {
+ my %values;
+
+ verbose "Enter <field>=<value> pairs and Ctrl-D to end input";
+
+ while (<STDIN>) {
+ if (/^(\s+)(=|:)(\.*)/) {
+ $values{$1} = $2;
+ } # if
+ } # while
+
+ verbose "All <field>=<value> pairs accepted";
+
+ return %values;
+} # getFields
+
+$opts{module} = 'rest';
+
+GetOptions (
+ \%opts,
+ usage => sub { Usage },
+ verbose => sub { set_verbose },
+ debug => sub { set_debug },
+ 'module=s',
+ 'username=s',
+ 'password=s',
+ 'database=s',
+ 'dbset=s',
+ 'record=s',
+ 'key=s',
+ 'server=s',
+ 'port=i',
+ 'action=s',
+) || Usage;
+
+Usage "You must specify -key" unless $opts{key};
+
+# Default to Defect
+my $record = delete $opts{record} || 'Defect';
+my $key = delete $opts{key};
+my $action = delete $opts{action} || 'Modify';
+
+# Translate any options to ones that the lib understands
+$opts{CQ_USERNAME} = delete $opts{username};
+$opts{CQ_PASSWORD} = delete $opts{password};
+$opts{CQ_DATABASE} = delete $opts{database};
+$opts{CQ_DBSET} = delete $opts{dbset};
+$opts{CQ_SERVER} = delete $opts{server};
+$opts{CQ_PORT} = delete $opts{port};
+
+my $cq;
+
+my $module = lc delete $opts{module};
+
+if ($module eq 'rest') {
+ require Clearquest::REST;
+
+ $cq = Clearquest::REST->new (%opts);
+} elsif ($module eq 'client') {
+ require Clearquest::Client;
+
+ $cq = Clearquest::Client->new (%opts);
+
+ $cq->connect;
+} elsif ($module eq 'api') {
+ require Clearquest;
+
+ $cq = Clearquest->new (%opts);
+
+ $cq->connect;
+} else {
+ Usage "Invalid module - $opts{module}";
+} # if
+
+# Fix key if necessary
+if ($key =~ /^(\d+)$/) {
+ $key = $cq->{database} . 0 x (8 - length $1) . $1;
+} # if
+
+my %values = getFields;
+
+my $errmsg = $cq->modify ($record, $key, $action, %values);
+
+unless ($cq->cqerror) {
+ verbose "Successfully applied $action to $record:$key";
+
+ exit 0;
+} else {
+ error "Unable to apply $action to $record:$key\n" . $cq->cqerrmsg, $cq->cqerror;
+} # unless
\ No newline at end of file
--- /dev/null
+#!cqperl
+use strict;
+use warnings;
+
+=pod
+
+=head1 NAME $RCSfile: cqd.pl,v $
+
+Clearquest Daemon - Daemon to provide access to Clearquest database
+
+This daemon instanciates an instance of the Clearquest::DBService to service
+requests for information of a Clearquest database or to update a Clearquest
+database.
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 2.4 $
+
+=item Created:
+
+Mon Oct 24 16:19:15 PDT 2011
+
+=item Modified:
+
+$Date: 2013/03/15 00:15:32 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage: cqd.pl [-u|sage] [-v|erbose] [-d|ebug]
+ [-logfile <logfile>] [-[no]daemon]
+ [-s|erver <server>] [-p|ort <n>]
+
+ Where:
+ -u|sage: Displays usage
+ -v|erbose: Be verbose
+ -de|bug: Output debug messages
+
+ -s|erver <server>: Server to talk to (Default: from conf file or
+ environment)
+ -p|ort <n> Port nbr to use (Default: from conf file or
+ environment)
+ -m|ultithreaded
+ -logfile <logfile>: Where to log output (Default: STDOUT)
+ -[no]daemon: Enter daemon mode (Default: Enter daemon mode)
+
+ -s|erver: For module = client or rest this is the name of the server
+ that will be providing the service
+ -p|ort: For module = client, this is the point on the server to talk
+ through.
+
+=head1 Options
+
+Options are keep in the cq.conf file in etc. They specify the default options
+listed below. Or you can export the option name to the env(1) to override the
+defaults in cq.conf. Finally you can programmatically set the options when you
+call new by passing in a %parms hash. To specify the %parms hash key remove the
+CQ_ portion and lc the rest.
+
+=for html <blockquote>
+
+=over
+
+=item CQ_SERVER
+
+Clearquest::Server name to connect to (Default: from config file)
+
+=item CQ_PORT
+
+Clearquest::Server port to connect to (Default: from config file)
+
+=back
+
+=cut
+
+use Config;
+use File::Spec;
+use FindBin;
+use Getopt::Long;
+
+use CQPerlExt;
+
+use lib "$FindBin::Bin/../lib";
+
+use Clearquest::Server;
+use Display;
+use Utils;
+
+my $VERSION = '$Revision: 2.4 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+my %opts;
+
+GetOptions (
+ \%opts,
+ verbose => sub { set_verbose },
+ debug => sub { set_debug },
+ usage => sub { Usage },
+ 'server=s',
+ 'port=i',
+ 'logfile=s',
+ 'multithreaded!',
+ 'daemon!',
+ 'serviceClient=s',
+ 'socket=s',
+) || Usage;
+
+my %parms = (
+ CQ_SERVER => $opts{server},
+ CQ_PORT => $opts{port},
+ CQ_MULTITHREADED => $opts{multithreaded},
+);
+
+my $cqservice = Clearquest::Server->new (%parms);
+
+if ($opts{serviceClient}) {
+ $cqservice->{clientname} = $opts{serviceClient};
+
+ debug "In cqd.pl with -serviceClient $cqservice->{clientname} - opening socket";
+
+ open my $client, '+<&=', *STDIN
+ or error "Unable to open socket connection to client", 1;
+
+ $client->autoflush (1);
+
+ debug "Socket open - servicing client = $client";
+ $cqservice->_serviceClient ($client);
+ debug "Returned from servicing client";
+
+ exit;
+} # if
+
+my $announcement = "$FindBin::Script v$VERSION ";
+ $announcement .= $cqservice->multithreaded
+ ? '(Multithreaded)'
+ : '(Singlethreaded)';
+
+verbose $announcement;
+
+if ($opts{daemon} and !get_debug and !defined $DB::OUT) {
+ print $DB::OUT "Debugging\n" if get_debug;
+
+ my ($logfile) = ($FindBin::Script =~ /(.*)\.pl$/);
+
+ $opts{logfile} ||= "$logfile.log";
+
+ $logfile = File::Spec->rel2abs ($opts{logfile});
+
+ verbose "Entering daemon mode (Server pid: $$ - logging to $logfile)";
+
+ if ($Config{perl} eq 'ratlperl') {
+ error "Unable to daemonize with cqperl", 1;
+ } else {
+ EnterDaemonMode $opts{logfile}, $opts{logfile};
+ } # if
+} # if
+
+delete $opts{daemon};
+delete $opts{multithreaded};
+
+verbose 'Starting Server';
+$cqservice->startServer;
+
+verbose 'Shutting down server';
+
+exit;
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: CheckinPreop.pl
+# Description: This trigger script is run when the user is attempting to
+# checkin. Several checks are performed on the check in comment.
+# The comment should contain the bug ID, which we will later used
+# to label this element checkin (See CheckinPostop.pl). We will
+# also check to insure the bug ID is valid in Clearquest and that
+# the bug is in the proper state.
+#
+# If the check in is on the "main" or "trial" branch then we will
+# consult a file to insure that the bug ID is listed. This is an
+# additional method for limiting checkins.
+# Assumptions: Clearprompt is in the users PATH
+# Author: Andrew@DeFaria.com
+# Created: Fri Oct 26 15:32:12 2001
+# Language: Perl
+# Modifications:6/25/2002: Added check to see if a bug ID label exists and it
+# is locked. If so then that's an indication that we should not
+# allow the checkin.
+# 6/20/2002: Added interface to cqd to verify that the bug exists
+# in Clearquest, is of a certain state and has an owner
+# 5/15/2002: Added tests so that bug IDs must exist in
+# mainbugs.txt or trialbugs.txt for the main and trial branches.
+# 5/17/2002: Exempted EMS code.
+# 5/31/2002: Exempted hardware code.
+# 10/22/2002: Changed to allow checkins to main branch with no
+# bug IDs. Removed $mainbugs.
+# 11/20/2002: It was determined to relax restrictions of checkins
+# for non 1.0 branches such that bug ID's are not required, in fact
+# they are not allowed.
+# 04/11/2003: Added support for multiple bug IDs in the comment
+# 05/18/2003: Changed code to only check for bug IDs in comments
+# for check ins on certain branches.
+#
+# (c) Copyright 2003, Andrew@DeFaria.com, all rights reserved
+#
+################################################################################
+use strict;
+
+my $site;
+
+BEGIN {
+ # Add the appropriate path to our modules to @INC array. We use ipconfig to
+ # get the current host's IP address then determine whether we are in the US
+ # or China.
+ my @ipconfig = grep (/IP Address/, `ipconfig`);
+ my ($ipaddr) = ($ipconfig[0] =~ /(\d{1,3}\.\d{1,3}.\d{1,3}\.\d{1,3})/);
+
+ # US is in the subnets of 192 and 172 while China is in the subnet of 10
+ if ($ipaddr =~ /^192|^172/) {
+ $site = "US";
+ unshift (@INC, "//sons-clearcase/Views/official/Tools/lib");
+ } elsif ($ipaddr =~ /^10/) {
+ $site = "CN";
+ unshift (@INC, "//sons-cc/Views/official/Tools/lib");
+ } else {
+ die "Internal Error: Unable to find our modules!\n"
+ } # if
+} # BEGIN
+
+use TriggerUtils;
+use cqc;
+
+%cqc::fields;
+
+# The following environment variables are set by Clearcase when this
+# trigger is called
+my $comment = $ENV{CLEARCASE_COMMENT};
+my $branch = $ENV{CLEARCASE_BRTYPE};
+my $pname = $ENV{CLEARCASE_PN};
+
+# Which vob we will look up labels in
+my $vob = "salira";
+
+my $bugid;
+
+sub ExtractBugID {
+ my $comment = shift;
+
+ my @fields = split (/\W/,$comment);
+ my $bugid = "unknown";
+
+ foreach (@fields) {
+ if (/BUGS2[0-9]{8}/) {
+ $bugid = $_;
+ last;
+ } # if
+ } # foreach
+
+ return $bugid;
+} # ExtractBugID
+
+sub ExtractBugIDs {
+ my $comment = shift;
+
+ my @fields = split (/\W/,$comment);
+
+ # Use associative array to insure uniqueness
+ my %bugids;
+ # Return unique array
+ my @bugids;
+
+ foreach (@fields) {
+ if (/BUGS2[0-9]{8}/) {
+ $bugids{$_} = $_;
+ } # if
+ } # foreach
+
+ foreach (keys %bugids) {
+ push @bugids, $_;
+ }
+
+ return @bugids;
+} # ExtractBugIDs
+
+sub BugOnList {
+ my $bugid = shift;
+ my $branch = shift;
+
+ my $found_bugid = 0;
+ my $bug = "unknown";
+
+ # Excempt EMS code
+ return 1 if $pname =~ /salira\\ems/i;
+
+ # Excempt Hardware code
+ return 1 if $pname =~ /salira\\hardware/i;
+
+ # Exempt bug ID 2912
+ return 1 if $bugid eq "BUGS200002912";
+
+ # Exempt bug ID 3035
+ return 1 if $bugid eq "BUGS200003035";
+
+ my $filename;
+
+ if ($site eq "US") {
+ $filename = "//sons-clearcase/Views/official/Tools/bin/clearcase/triggers/data/$branch.lst";
+ } elsif ($site eq "CN") {
+ $filename = "//sons-cc/Views/official/Tools/bin/clearcase/triggers/data/$branch.lst";
+ } else {
+ die "Internal Error: Site not set properly! ($site)\n";
+ } # if
+
+ if (-f $filename) {
+ open (FILE, $filename) || die "Can't open $filename!\n";
+
+ while (<FILE>) {
+ $bug = ExtractBugID $_;
+ next if ($bug eq "unknown");
+ if ($bug eq $bugid) {
+ $found_bugid = 1;
+ last;
+ } # if
+ } # while
+
+ close (FILE);
+ } else {
+ clearlog "Skipping check because $filename does not exist!";
+ # Since there is no file list to check return that the bug id was found
+ $found_bugid = 1;
+ } # if
+
+ return $found_bugid;
+} # BugOnList
+
+sub LabelLocked {
+ # 04/28/2003: Oddity! All of a sudden this subroutine broke! I don't know
+ # why but even though we used to cd to the official view and issue our
+ # cleartool lslock command we started getting "Unable to determine VOB
+ # from pname" errors. Weird! Anyways we have changed to use the @<vob
+ # selector> syntax instead. This means we must now specify the vob
+ # specifically. Fortunately we only have one vob to worry about at this
+ # time. On the plus side we no longer need to rely on the "official" view.
+ my $bugid = shift;
+
+ my $output = `cleartool lslock -short lbtype:$bugid@\\$vob 2>&1`;
+
+ if ($? == 0) {
+ return $output;
+ } else {
+ return 0;
+ } # if
+} # LabelLocked
+
+sub CheckComment {
+ my $comment = shift;
+ my $branch = shift;
+
+ my @valid_branches = (
+ "main",
+ "rel_1.0",
+ "rel_2.0",
+ "rel_2.1",
+ "rel_2.2",
+ "rel_2.3",
+ "china_1.0",
+ "china_2.0",
+ "china_2.1",
+ "china_2.2",
+ "china_2.3",
+ "2.0_ga"
+ );
+
+ if ($comment eq "") {
+ clearlogmsg "You need to specify checkin comments";
+ return 1;
+ } # if
+
+ if (length $comment <= 4) {
+ clearlogmsg "The comment, '$comment' is too short!";
+ return 1;
+ } # if
+
+ if ($comment !~ m/.*BUGS2[0-9]{8}.*/) {
+ # Bug ID's are only required on certain branches
+ my $found = 0;
+
+ foreach (@valid_branches) {
+ if ($branch eq $_) {
+ $found = 1;
+ last;
+ } # if
+ } # foreach
+
+ if ($found == 1) {
+ clearlogmsg "Could not find bug ID in comment! This is required for the $branch branch";
+ return 1;
+ } # if
+ } # if
+
+ return 0;
+} # CheckComment
+
+sub CheckBugIDs {
+ my @bugs = @_;
+
+ my $result;
+
+ foreach my $bugid (@bugs) {
+ # Check if label is locked
+ if (LabelLocked ($bugid)) {
+ clearlog "Bug id $bugid is locked!";
+ clearmsg "Bug id $bugid is locked!\nSee your Clearcase Admin to unlock it";
+ return 1;
+ } # if
+
+ # Get Clearquest information
+ $result = cqc::GetBugRecord ($bugid, %fields);
+
+ if ($result == 0) {
+ # Make sure bug is owned
+ if ($fields {owner} eq "<Unspecified>") {
+ clearlogmsg "No owner specified in Clearquest for bug ID $bugid.";
+ return 1;
+ } # if
+
+ # Make sure bug is in the correct state
+ if ($fields {state} ne "Assigned" and $fields {state} ne "Resolved") {
+ clearlogmsg "Bug ID $bugid is in the wrong state. It is in the " . $fields {state}. " state but should be in Assigned or Resolved state.";
+ return 1;
+ } # if
+ } elsif ($result > 0) {
+ clearlogmsg "Bug ID $bugid is not in Clearquest.";
+ return 1;
+ } else {
+ clearlogmsg "Clearquest Daemon (cqd) is not running!
+Please contact the Clearquest Administrator.";
+ return 1;
+ } # if
+
+ # Check if bug is on a branch list file
+ if (! BugOnList ($bugid, $branch)) {
+ clearlog "Bug ID $bugid is not on the list of acceptable bugs for the $branch branch!";
+ clearmsg "Bug ID $bugid is not on the list\nof acceptable bugs for the $branch branch!";
+ return 1;
+ } # if
+ } # foreach
+} # CheckBugIDs
+
+clearlog "Checkin checks started for $pname on $branch branch";
+
+if (CheckComment ($comment, $branch)) {
+ exit 1;
+} elsif (CheckBugIDs (ExtractBugIDs $comment)) {
+ exit 1;
+} # if
+
+clearlog "Successful precheckin of $pname on $branch branch with bug ID $bugid";
+
+exit 0;
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: cqc,v
+# Revision: 1.1.1.1
+# Description: This script is a test client for cqd.
+# Author: Andrew@DeFaria.com
+# Created: Fri May 31 15:34:50 2002
+# Modified: 2007/05/17 07:45:48
+# Language: Perl
+#
+# (c) Copyright 2007, ClearSCM, Inc. , all rights reserved.
+#
+################################################################################
+use strict;
+
+BEGIN {
+ # Add the appropriate path to our modules to @INC array. We use ipconfig to
+ # get the current host's IP address then determine whether we are in the US
+ # or China.
+ my @ipconfig = grep (/IP Address/, `ipconfig`);
+ my ($ipaddr) = ($ipconfig[0] =~ /(\d{1,3}\.\d{1,3}.\d{1,3}\.\d{1,3})/);
+
+ # US is in the subnets of 192 and 172 while China is in the subnet of 10
+ if ($ipaddr =~ /^192|^172/) {
+ unshift (@INC, "//sons-clearcase/Views/official/Tools/lib");
+ } elsif ($ipaddr =~ /^10/) {
+ unshift (@INC, "//sons-cc/Views/official/Tools/lib");
+ } else {
+ die "Internal Error: Unable to find our modules!\n"
+ } # if
+} # BEGIN
+
+use cqc;
+
+%cqc::fields;
+$cqc::command;
+
+my $len;
+my $key;
+my $value;
+my $servername = $ENV {CQDSERVER};
+my $bugid;
+my @query_fields;
+my $result;
+
+sub Usage {
+ print "Usage: cqc [ -s servername ] bugid [ fieldname... ]\n";
+ exit 1;
+} # Usage
+
+$bugid = "";
+@query_fields = ();
+
+sub GetParms {
+ my $i = 0;
+
+ if ($ARGV [0] && $ARGV [0] eq "-s") {
+ shift (@ARGV);
+ if (!$ARGV [0]) {
+ Usage;
+ } else {
+ $servername = shift (@ARGV);
+ } # if
+ } # if
+
+ if ($ARGV [0]) {
+ $bugid = shift (@ARGV);
+ } # if
+
+ @query_fields = @ARGV;
+
+ # Downshift any query_fields
+ foreach (@query_fields) {
+ $query_fields [$i++] = lc $_;
+ } # foreach
+} # GetParms
+
+sub fix_bugid {
+ my $bugid = shift;
+
+ if ($bugid =~ /^\d+$/) {
+ if (length ($bugid) < 13) {
+ $len = 13 - length ($bugid);
+ if ($len < 5) {
+ # Can't even prepend "BUGS2"!
+ print "Invalid bug id \"$bugid\" encountered!\n";
+ exit 1;
+ } else {
+ $bugid = "BUGS2" . "0" x ($len - 5) . $bugid;
+ } # if
+ } # if
+ } # if
+
+ return $bugid;
+} # fix_bugid
+
+# Main code
+GetParms;
+
+if (defined ($servername)) {
+ die "Unable to connect to $servername\n" if cqc::Connect ($servername) < 0;
+} # if
+
+if ($bugid) {
+ $result = cqc::GetBugRecord (fix_bugid ($bugid), %fields);
+ die "Unable to connect to server\n" if $result < 0;
+ if ($result) {
+ print "Bug ID $bugid was not found\n";
+ } else {
+ if (@query_fields) {
+ foreach (@query_fields) {
+ if (@query_fields > 1) {
+ print "$_: $cqc::fields{$_}\n";
+ } else {
+ print "$cqc::fields{$_}\n";
+ } # if
+ } # foreach
+ } else {
+ while (($key, $value) = each (%fields)) {
+ $value =~ s/\r/\r\n/g;
+ print "$key: $value\n";
+ } # while
+ } # if
+ } # if
+} else {
+ print "Enter bug ID:";
+
+ while ($command = <STDIN>) {
+ chomp $command;
+ last if $command =~ m/exit|quit|shutdown/;
+
+ $bugid = fix_bugid ($command);
+ $result = cqc::GetBugRecord ($bugid, %fields);
+ die "Unable to connect to server\n" if $result < 0;
+ if ($result) {
+ print "Bug ID $bugid was not found\n";
+ } else {
+ while (($key, $value) = each (%fields)) {
+ $value =~ s/\r/\r\n/g;
+ print "$key: $value\n";
+ } # while
+ } # if
+
+ print "Enter bug ID:";
+ } # while
+} # if
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: cqc.pm,v
+# Revision: 1.1.1.1
+# Description: Perl Module interface to cqd (ClearQuest Daemon). This is used
+# by cqc and cgi script to talk to cqd.
+# Author: Andrew@DeFaria.com
+# Created: Fri May 31 15:34:50 2002
+# Modified: 2007/05/17 07:45:48
+# Language: Perl
+#
+# (c) Copyright 2007, ClearSCM, Inc., all rights reserved.
+#
+################################################################################
+use IO::Socket;
+
+package cqc;
+ require (Exporter);
+ @ISA = qw (Exporter);
+
+ @EXPORT = qw (
+ Connect
+ GetBugRecord
+ Disconnect
+ %fields
+ $command
+ $verbose
+ );
+
+ my $host;
+ my $port = 1500;
+ my $command;
+ my $default_server = "sons-clearcase";
+ my $verbose;
+
+ BEGIN {
+ my $cqcversion = "1.0";
+
+ # Reopen STDOUT. This is because cqperl screws around with STDOUT in some
+ # weird fashion
+ open STDOUT, ">-" or die "Unable to reopen STDOUT\n";
+ # Set unbuffered output for the same reason (cqperl)
+ $| = 1;
+ } # BEGIN
+
+ sub verbose {
+ print "@_\n" if defined ($verbose);
+ } # verbose
+
+ sub Connect {
+ my $host = shift;
+
+ my $result;
+
+ if (!defined ($host)) {
+ $host = "localhost";
+ } # if
+
+ $cqserver = ConnectToServer ($host);
+
+ if ($cqserver) {
+ verbose "Connected to $host";
+ SendServerAck ($cqserver);
+ } # if
+
+ return $cqserver;
+ } # Connect
+
+ sub Disconnect {
+ my $msg;
+ if ($cqserver) {
+ if ($cqc::command eq "shutdown") {
+ $msg = "Disconnected from server - shutdown server";
+ } else {
+ $cqc::command = "quit";
+ $msg = "Disconnected from server";
+ } # if
+ SendServerCmd ($cqserver, $cqc::command);
+ GetServerAck ($cqserver);
+ verbose "$msg";
+ close ($cqserver);
+ undef $cqserver;
+ } # if
+ } # Disconnect
+
+ sub GetBugRecord {
+ my $bugid = shift;
+ %fields = @_;
+
+ my $result;
+
+ if (!$cqserver) {
+ verbose "Not connected to server yet!\n";
+ verbose "Attempting connection to $default_server...\n";
+ $result = Connect ($default_server);
+ return -1 if !defined ($result);
+ } # if
+
+ SendServerCmd ($cqserver, $bugid);
+ GetServerAck ($cqserver);
+ $result = GetServerResponse ($cqserver, %fields);
+ SendServerAck ($cqserver);
+
+ return $result;
+ } # GetBugRecord
+
+ END {
+ Disconnect;
+ } # END
+
+ sub ConnectToServer {
+ my $host = shift;
+
+ # create a tcp connection to the specified host and port
+ return IO::Socket::INET->new(Proto => "tcp",
+ PeerAddr => $host,
+ PeerPort => $port);
+ } # ConnectToServer
+
+ sub SendServerAck {
+ my $server = shift;
+
+ print $server "ACK\n";
+ } # SendServerAck
+
+ sub GetServerAck {
+ my $server = shift;
+ my $srvresp;
+
+ while (defined ($srvresp = <$server>)) {
+ chomp $srvresp;
+ if ($srvresp eq "ACK") {
+ return;
+ } # if
+ print "Received $srvresp from server - expected ACK\n";
+ } # while
+ } # GetServerAck
+
+ sub GetServerResponse {
+ my $server = shift;
+ %fields = @_;
+
+ %fields = ();
+ my $srvresp;
+ my $result = 0;
+
+ while (defined ($srvresp = <$server>)) {
+ chomp $srvresp;
+ last if $srvresp eq "ACK";
+ if ($srvresp =~ m/Bug ID.*was not found/) {
+ $result = 1;
+ } else {
+ $srvresp =~ /(^\w+):\s+(.*)/s;
+ $fields {$1} = $2;
+ } # if
+ } # while
+
+ return $result;
+ } # GetServerResponse
+
+ sub SendServerCmd {
+ my $server = shift;
+ my $command = shift;
+
+ print $server "$command\n";
+ } # SendServerCmd
+
+1;
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+
+ <title>ClearSCM: Clearquest: Deamon: CQD</title>
+
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Article.css">
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Code.css">
+ <link rel="stylesheet" type="text/css" media="print" href="/css/Print.css">
+ <link rel="SHORTCUT ICON" href="http://clearscm.com/favicon.ico" type="image/png">
+
+ <!-- Google Analytics
+ <script src="http://www.google-analytics.com/urchin.js" type="text/javascript">
+ </script>
+ <script type="text/javascript">
+ _uacct = "UA-89317-1";
+ urchinTracker ();
+ </script>
+ Google Analytics -->
+
+ <?php
+ include "clearscm.php";
+ menu_css ();
+ ?>
+</head>
+
+<body>
+
+<?php heading ();?>
+
+<div id="page">
+ <div id="content">
+ <?php start_box ("cs5");?>
+ <h2>Clearquest Daemon API (code)</h2>
+
+ <p>Defines the API to the Clearquest Daemon.</p>
+
+ <?php end_box ();?>
+
+ <?php display_code ("/opt/clearscm/cq/cqd/cqc.pm");?>
+ </div>
+ <?php copyright ();?>
+</div>
+
+<script language="JavaScript" src="/JavaScript/Menus.js" type="text/javascript"></script>
+
+</body>
+</html>
--- /dev/null
+#!C:/Progra~1/Rational/ClearQuest/CQPerl
+################################################################################
+#
+# File: cqd,v
+# Revision: 1.1.1.1
+# Description: This script implements a daemon that handles requests for
+# queries to the Clearquest database. Opening up the Clearquest
+# database takes a long time, therefore this daemon will run in
+# the background and handle requests.
+# Author: Andrew@DeFaria.com
+# Created: Fri May 31 15:34:50 2002
+# Modified: 2007/05/17 07:45:48
+# Language: Perl
+#
+# (c) Copyright 2007, ClearSCM, Inc., all rights reserved.
+#
+################################################################################
+use strict;
+use CQPerlExt;
+use IO::Socket;
+use Net::hostent;
+use POSIX qw(setsid);
+
+# Generic, harmless, user reporter
+my $cquser = "reporter";
+my $cqpasswd = "news";
+my $cqdb = "BUGS2";
+my $port = 1500;
+
+my $session;
+my $verbose;
+my $daemon_mode;
+my $quiet_mode;
+my $multithreaded;
+my $pid = $$;
+
+my $me = `basename $0`;
+chomp $me;
+my $cqdversion = "2.0";
+
+my @all_fields = (
+ "cc", "description", "field_trial",
+ "fixed_date", "fixed_in", "found_in",
+ "headline", "manager", "module",
+ "must_fix", "note_entry", "notes_log",
+ "owner", "pending_reason", "priority",
+ "product", "project", "resolution",
+ "severity", "state", "submit_date",
+ "submitter", "symptoms", "verified_by",
+ "verified_date", "resolution_statetype", "keywords",
+ "fixed_by"
+);
+
+my %fields= ();
+
+sub log_message {
+ print "[$pid] @_\n" if defined ($verbose);
+} # log_message
+
+sub display_message {
+ print "[$pid] @_\n" if !defined ($quiet_mode);
+} # display_message
+
+sub log_error {
+ print STDERR "[$pid] ERROR: @_\n"
+} # log_error
+
+sub log_warning {
+ print STDERR "[$pid] WARNING: @_\n"
+} # log_error
+
+sub GetClientAck {
+ my $client = shift;
+ my $clientresp;
+
+ while (defined ($clientresp = <$client>)) {
+ chomp $clientresp;
+ if ($clientresp eq "ACK") {
+ return
+ } # if
+ log_warning "Received $clientresp from client - expected ACK";
+ } # while
+} # GetClientAck
+
+sub GetClientCmd {
+ my $client = shift;
+ my $clientresp;
+
+ while (defined ($clientresp = <$client>)) {
+ chomp $clientresp;
+ return $clientresp;
+ } # while
+} # GetClientResponse
+
+sub SendClientAck {
+ my $client = shift;
+
+ print $client "ACK\n";
+} # SendClientAck
+
+sub SendClientResponse {
+ my $client = shift;
+ my $response = shift;
+
+ print $client "$response\n";
+} # SendClientResponse
+
+sub EnterDaemonMode {
+ my $logfile = shift (@_);
+ my $errorlog = shift (@_);
+
+ log_message "Entering Daemon Mode (\"$logfile\", \"$errorlog\")";
+ if ($logfile eq '') {
+ $logfile = "/dev/null";
+ } # if
+
+ if ($errorlog eq '') {
+ $errorlog = "/dev/null";
+ } # if
+
+ # Change the current directory to /
+ chdir 'C:\\' or die "$me: Error: Can't chdir to C:\\ ($!)";
+
+ # Turn off umask
+ umask 0;
+
+ # Redirect STDIN to /dev/null
+ open STDIN, '/dev/null'
+ or die "$me: Error: Can't read /dev/null ($!)";
+
+ # Redirect STDOUT to logfile
+ open STDOUT, ">>$logfile"
+ or die "$me: Error: Can't write to $logfile ($!)";
+
+ # Redirect STDERR to errorlog
+ open STDERR, ">>$errorlog"
+ or die "$me: Error: Can't write to $errorlog ($!)";
+
+ # Now fork the daemon
+ defined (my $pid = fork)
+ or die "$me: Error: Can't create daemon ($!)";
+
+ # Now the parent exits
+ exit if $pid;
+
+ # Set process to be session leader
+ setsid
+ or die "$me: Error: Can't start a new session ($!)";
+ log_message "Entered Daemon Mode";
+} # EnterDaemonMode
+
+sub OpenDB {
+ log_message "Opening $cqdb database";
+ $session = CQPerlExt::CQSession_Build ();
+ $session->UserLogon ($cquser, $cqpasswd, $cqdb, "");
+ log_message "Opened $cqdb database";
+} # OpenDB
+
+sub CloseDB {
+ CQSession::Unbuild ($session);
+} # CloseDB
+
+sub Usage {
+ print "Usage: $me [ -d ] [ -v ] [ -m ] [ -q ]\n\n";
+ print "Where:\t-d\tEnter Daemon mode (currently not working)\n";
+ print "\t-v\tVerbose mode\n";
+ print "\t-m\tMultithreaded (currently not working)\n";
+ print "\t-q\tQuiet mode\n";
+ exit 1;
+} # Usage
+
+sub GetBugRecord {
+ my $bugid = shift;
+ %fields = @_;
+
+ my $record;
+ my $value;
+
+ # Use eval because the bug ID passed in may not be found. If there is
+ # an error with this call we assume the bug ID is not valid.
+ eval {
+ $record = $session->GetEntity ("defect", $bugid);
+ } or log_error "Bug ID $bugid not found!", return 0;
+
+ foreach (@all_fields) {
+ # The field name specified may be undefined. It may also just be
+ # not filled in. We need to use eval to attempt to get the field and
+ # then determine which error it was: Undefined field or simply a field
+ # that was not filled in.
+ eval {
+ $value = $record->GetFieldValue ($_)->GetValue
+ };
+ if ($@ =~ m/object that does not exist/) {
+ $value = "<Undefined field>";
+ } elsif ($value eq "") {
+ $value = "<Unspecified>";
+ } # if
+ $value =~ tr/\n/ /s;
+ $fields {$_} = $value;
+ } # foreach
+
+ return 1;
+} # GetBugRecord
+
+sub ServiceClient {
+ my $cqclient = shift;
+
+ # Service this client
+ my $hostinfo = gethostbyaddr ($cqclient->peeraddr);
+ my $host = $hostinfo->name || $cqclient->peerhost;
+
+ display_message "Connect from $host";
+ log_message "Waiting for command from $host";
+ while () {
+ GetClientAck ($cqclient);
+ $_ = GetClientCmd ($cqclient);
+ next unless /\S/; # Skip blank requests
+ last if /quit|exit|shutdown/i;
+ log_message "$host requests information about bug ID $_";
+ SendClientAck ($cqclient);
+ if (GetBugRecord ($_, %fields)) {
+ SendClientResponse ($cqclient, "id: $_");
+ my $key;
+ my $value;
+ while (($key, $value) = each (%fields)) {
+ SendClientResponse ($cqclient, "$key: $value");
+ } # while
+ } else {
+ SendClientResponse ($cqclient, "Bug ID $_ was not found");
+ } # if
+ SendClientAck ($cqclient);
+ } # while
+
+ display_message "Closing connection from $host at client's request";
+ close $cqclient;
+} # ServiceClient
+
+sub Funeral {
+ my $childpid = wait;
+ $SIG{CHLD} = \&Funeral;
+ log_message "Child has died" . ($? ? " with status $?" : "");
+} # Funeral
+
+sub ProcessRequests {
+ # The subroutine handles processing of requests by using a socket to
+ # communicate with clients.
+ my $cqserver = IO::Socket::INET->new (
+ Proto => 'tcp',
+ LocalPort => $port,
+ Listen => SOMAXCONN,
+ Reuse => 1
+ );
+
+ die "$me: Error: Could not create socket (%!)\n" unless $cqserver;
+
+ display_message "Clearquest DB Server (cqd V$cqdversion) accepting clients";
+
+ # Now wait for an incoming request
+ while (my $cqclient = $cqserver->accept ()) {
+ my $hostinfo = gethostbyaddr ($cqclient->peeraddr);
+ my $host = $hostinfo->name || $cqclient->peerhost;
+ log_message "$host is requesting service";
+ if (defined ($multithreaded)) {
+ my $childpid;
+
+ log_message "Spawning child to handle request";
+
+ die "$me: ERROR: Can't fork: %!" unless defined ($childpid = fork ());
+
+ if ($childpid) {
+ # In parent - set up for clean up of child process
+ log_message "In parent";
+ $childpid = -$childpid;
+ log_message "Parent produced child ($childpid)";
+ $SIG{CHLD} = \&Funeral;
+ log_message "Parent looking for another request to service";
+ } else {
+ # In child process - ServiceClient
+ log_message "In child";
+ $pid = -$$;
+ log_message "Child has been born";
+ ServiceClient ($cqclient);
+ log_message "Child finished servicing requests";
+ kill ("TERM", $$);
+ exit;
+ } # if
+ } else {
+ ServiceClient ($cqclient);
+ } # if
+ } # while
+
+ display_message "Shutting down server";
+ close ($cqserver);
+
+} # ProcessRequests
+
+# Start main code
+# Reopen STDOUT. This is because cqperl screws around with STDOUT in some
+# weird fashion
+open STDOUT, ">-" or die "Unable to reopen STDOUT\n";
+# Set unbuffered output for the same reason (cqperl)
+$| = 1;
+
+while ($ARGV [0]) {
+ if ($ARGV [0] eq "-d") {
+ $daemon_mode = 1;
+ } elsif ($ARGV [0] eq "-v") {
+ $verbose = 1;
+ undef ($quiet_mode);
+ } elsif ($ARGV [0] eq "-m") {
+ $multithreaded = 1;
+ } elsif ($ARGV [0] eq "-q") {
+ $quiet_mode = 1;
+ undef ($verbose);
+ } else {
+ Usage;
+ } # if
+ shift (@ARGV);
+} # while
+
+my $tmp = $ENV {"TMP"};
+my $cqd_logfile = "$tmp\\$me.log";
+my $cqd_errfile = "$tmp\\$me.err";
+
+EnterDaemonMode ($cqd_logfile, $cqd_errfile) if defined ($daemon_mode);
+
+OpenDB;
+
+ProcessRequests;
+
+display_message "Shutting down";
+
+CloseDB;
+display_message "Closed $cqdb database";
+
+exit 0;
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: releasenotes.cgi,v
+# Revision: 1.1.1.1
+# Description: Produce an HTML table of bugs for a release page
+# Author: Andrew@DeFaria.com
+# Created: Fri May 31 15:34:50 2002
+# Modified: 2007/05/17 07:45:48
+# Language: Perl
+#
+# (c) Copyright 2007, ClearSCM, Inc., all rights reserved.
+#
+################################################################################
+use strict;
+use CGI qw/:standard *table/;
+use Cwd;
+use lib qw(//sonscentral/users/adefaria/www/cgi-bin);
+use cqc;
+
+#%cqc::fields;
+#$cqc::command;
+
+my $page = new CGI;
+
+my $release = $page->param ("release");
+my @intro_notes;
+my @buglines;
+
+# Colors
+my $header_background = "#ffffcc";
+my $header_foreground = "#000000";
+my $data_background = "#ffffff";
+my $data_foreground = "#000000";
+
+sub Error;
+sub Footing;
+
+sub ReleaseForm {
+ print
+ start_form ({-action => "/Release/releasenotes.cgi",
+ -method => "post"}) .
+ h4 ("Look up other Release:",
+ textfield ({-name => "release",
+ -size => 12,
+ -value => "Please specify"}),
+ submit ({-value => "Display"})
+ ) . end_form . "\n";
+} # ReleaseForm
+
+sub Heading {
+ my $release = shift;
+
+ if ($release) {
+ print header (-title => "Release $release") . "\n" .
+ start_html (-title => "Release $release",
+ -author => "Andrew\@DeFaria.com",
+ -link => "#0000ee",
+ -vlink => "#cc33cc",
+ -alink => "#ff0000",
+ -bgcolor => "#eeffff",
+ -text => "#000000",
+ -script => {-language => "JavaScript1.2",
+ -src => "/Javascript/Heading.js"}),
+ p ({-align => "right"},
+ a ({-href => "/Release/addbug"}, "Add a bug to a release") . "\n" . br
+ a ({-href => "file://///sons-clearcase/Views/official/Tools/bin/clearcase/triggers/data/rel_2.2.lst"}, "Official US 2.2 list") . "\n" . br
+ a ({-href => "file://///sons-cc/Views/official/Tools/bin/clearcase/triggers/data/china_2.2.lst"}, "Official Shanghai 2.2 list")) . "\n" .
+ h1 ({-align=>"CENTER"}, "Release $release") . "\n" .
+ h2 ("Introduction") . "\n";
+ } else {
+ print header (-title => "Release $release") . "\n" .
+ start_html (-title => "Release $release",
+ -author => "Andrew\@DeFaria.com") . "\n";
+ Error "Release not specified!";
+ } # if
+} # Heading
+
+sub Footing {
+ ReleaseForm;
+ print script ({-language => "JavaScript1.2",
+ -src => "/JavaScript/Footing.js"}) . "\n";
+ print end_html;
+} # Footing
+
+sub PrintIntroNotes {
+ (scalar (@intro_notes) == 0) ? return : print ul (@intro_notes) . "\n";
+} # PrintIntroNotes
+
+sub LockedLabel {
+ my $bugid = shift;
+
+ # We need to set a view context. Use the official view
+ my $cwd = cwd;
+
+ my $vob_server = "sons-clearcase";
+ my $view_path = "Views";
+ my $view_name = "official";
+ my $vob = "salira";
+ my $official_view = '\\\\' .
+ $vob_server .
+ '\\' .
+ $view_path .
+ '\\' .
+ $view_name .
+ '\\' .
+ $vob;
+
+ chdir $official_view or die "Unable to set view context";
+ my $output = `cleartool lslock -short lbtype:$bugid`;
+ chomp $output;
+ chdir $cwd or die "Unable to return from view context\n";
+
+ # lslock returns the label if it is locked, otherwise it returns
+ # an empty string
+ return $output;
+} # LabelLocked
+
+sub ParseBugFile {
+ my $buglist = shift;
+ my ($result, $owner, $description, $bugid, $state, $line);
+ my $bugnbr = 0;
+ my $locked;
+
+ open BUGLIST, "$buglist" or Error "Unable to open buglist: $buglist";
+
+ while ($line = <BUGLIST>) {
+ next if $line =~ /^\#/; # Skip comments
+ chomp $line;
+ if ($line =~ /^\*/) {
+ ($result, $line) = split (/\* /, $line);
+ push (@intro_notes, li ([$line]) . "\n");
+ } else {
+ ($bugid) = split (/\s+/, $line);
+ $result = cqc::GetBugRecord ($bugid, %fields);
+ ($result <= 0) ? $owner = "Unknown" : $owner = $fields {owner};
+ if ($result < 0) {
+ $description = "Unable to connect to server!";
+ } elsif ($result > 0) {
+ $description = "Bug ID not found in Clearquest!";
+ } else {
+ # Description's too large. Use headline instead.
+ $description = $fields {headline};
+ } # if
+
+ if (LockedLabel ($bugid)) {
+ $locked = img ({-src => "/Images/CheckMark.gif"});
+ } else {
+ $locked = " ";
+ } #if
+
+ if ($fields {state} eq "Verified" or $fields {state} eq "Closed") {
+ $state = $fields {state};
+ $locked = img ({-src => "/Images/CheckMark.gif"});
+ } else {
+ $state = b (font ({-color => "Red"}, $fields {state}));
+ } # if
+
+ push (@buglines,
+ td ({-width => "25",
+ -align => "center",
+ -bgcolor => $data_background},
+ small ++$bugnbr) .
+ td ({-bgcolor => $data_background},
+ small (a ({-href => "/cgi-bin/bugdetails.cgi?bugid=$bugid"}, $bugid))) .
+ td ({-bgcolor => $data_background},
+ small $state) .
+ td ({-align => "center",
+ -bgcolor => $data_background},
+ small (a ({-href => "mailto:$owner\@salira.com"}, $owner))) .
+ td ({-align => "center",
+ -valign => "center",
+ -bgcolor => $data_background},
+ $locked) .
+ td ({-bgcolor => $data_background},
+ small $description) . "\n");
+ } # if
+ } # while
+} # ParseBugFile
+
+sub PrintBugTable {
+ if (scalar (@buglines) == 0) {
+ print h3 ("No bugs found!");
+ } else {
+ my $bugs = (scalar (@buglines) > 1) ? " bugs" : " bug";
+ print "<table cellpadding=0 cellspacing=1 border=0 width=95% align=center bgcolor=Black>\n";
+ print caption (small (strong (scalar (@buglines) . $bugs . " in this release"))) . "\n";
+ print "<tbody><tr><td valign=top>\n";
+ print start_table({-align => "center",
+ -border => 1,
+ -cellspacing => 1,
+ -cellpadding => 2,
+ -width => "100%"}) . "\n" .
+ Tr ({-valign => "top", -bgcolor => $header_background}, [
+ th ({-width => "25"},
+ font ({-color => $header_foreground}, small ("#"))) .
+ th (font ({-color => $header_foreground}, small ("Bug ID"))) .
+ th (font ({-color => $header_foreground}, small ("State"))) .
+ th (font ({-color => $header_foreground}, small ("Owner"))) .
+ th (font ({-color => $header_foreground}, small ("Locked?"))) .
+ th (font ({-color => $header_foreground}, small ("Description")))
+ ]) . "\n" .
+ Tr({-valign=>"TOP"}, \@buglines) . "\n" .
+ end_table . "\n" .
+ end_table;
+ } # if
+} # PrintBugTable
+
+sub Error {
+ my $errmsg = shift;
+ print h3 ({-style => "Color: red;",
+ -align => "CENTER"}, "ERROR: " . $errmsg);
+ Footing;
+ exit 1;
+} # Error
+
+# Main
+Heading $release;
+if ($release) {
+ ParseBugFile ($release . ".bugs");
+ PrintIntroNotes (@intro_notes);
+ PrintBugTable (@buglines);
+ Footing;
+} # if
--- /dev/null
+#!/usr/bin/perl
+use strict;
+use warnings;
+
+=pod
+
+=pod
+
+=head1 NAME $RCSfile: cqinfo.pl,v $
+
+Clearquest Info
+
+This script takes some parameters and gets information from a Clearquest
+database.
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.6 $
+
+=item Created:
+
+Mon Jul 30 12:05:45 PDT 2012
+
+=item Modified:
+
+$Date: 2013/03/15 00:19:36 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage: cqinfo.pl [-u|sage] [-v|erbose] [-d|ebug]
+ [-username <username>] [-password <password>]
+ [-database <dbname>] [-dbset <dbset>]
+ [-record <record>] [-key <key>]
+ [-fields <field1>,<field2>,...]
+ [-module] [-server <server>] [-port <port>]
+
+ Where:
+ -u|sage: Displays usage
+ -v|erbose: Be verbose
+ -de|bug: Output debug messages
+
+ -r|ecord: Record to interrogate (Default: Defect)
+ -k|ey: Key to locate the record with (Note that if you supply
+ simply a number (e.g. 1234) then we will expand that with
+ leading zeroes to the length of 8 digits and prepend the
+ database name)
+ -f|ields: List of fields to display (Default: All fields)
+
+ -use|rname: Username to open database with (Default: from config file)
+ -p|assword: Password to open database with (Default: from config file)
+ -da|tabase: Database to open (Default: from config file)
+ -db|set: Database Set to use (Default: from config file)
+ -m|odule: Type of Clearquest module to use. Must be one of 'api',
+ 'client', or 'rest'. The 'api' module can only be used if
+ Clearquest is installed locally. The 'client' module can
+ only be successful if a corresponding server is running. And
+ the 'rest' module can only be used if a CQ Web server has
+ been set up and configured (Default: rest)
+ -s|erver: For module = client or rest this is the name of the server
+ that will be providing the service
+ -p|ort: For module = client, this is the point on the server to talk
+ through.
+
+=head1 Options
+
+Options are keep in the cq.conf file in etc. They specify the default options
+listed below. Or you can export the option name to the env(1) to override the
+defaults in cq.conf. Finally you can programmatically set the options when you
+call new by passing in a %parms hash. To specify the %parms hash key remove the
+CQ_ portion and lc the rest.
+
+=for html <blockquote>
+
+=over
+
+=item CQ_WEBHOST
+
+The web host to contact with leading http://
+
+=item CQ_DATABASE
+
+Name of database to connect to (Default: from config file)
+
+=item CQ_USERNAME
+
+User name to connect as (Default: from config file)
+
+=item CQ_PASSWORD
+
+Password for CQ_USERNAME
+
+=item CQ_DBSET
+
+Database Set name (Default: from config file)
+
+=item CQ_SERVER
+
+Clearquest::Server name to connect to (Default: from config file)
+
+=item CQ_PORT
+
+Clearquest::Server port to connect to (Default: from config file)
+
+=back
+
+=cut
+
+use FindBin;
+use Getopt::Long;
+
+use lib "$FindBin::Bin/../lib";
+
+use Clearquest;
+use Display;
+use Utils;
+
+my %opts;
+
+GetOptions (
+ \%opts,
+ usage => sub { Usage },
+ verbose => sub { set_verbose },
+ debug => sub { set_debug },
+ 'module=s',
+ 'username=s',
+ 'password=s',
+ 'database=s',
+ 'dbset=s',
+ 'record=s',
+ 'key=s',
+ 'server=s',
+ 'port=i',
+ 'fields=s@',
+) || Usage;
+
+Usage "You must specify -key" unless $opts{key};
+
+$opts{module} = lc $opts{module} if $opts{module};
+
+# Default to Defect
+my $record = delete $opts{record} || 'Defect';
+my $key = delete $opts{key};
+my @fields;
+
+if ($opts{fields}) {
+ push @fields, split /\s*,\s*/ foreach (@{$opts{fields}});
+} # if
+
+# Translate any options to ones that the lib understands
+$opts{CQ_USERNAME} = delete $opts{username};
+$opts{CQ_PASSWORD} = delete $opts{password};
+$opts{CQ_DATABASE} = delete $opts{database};
+$opts{CQ_DBSET} = delete $opts{dbset};
+$opts{CQ_SERVER} = delete $opts{server};
+$opts{CQ_PORT} = delete $opts{port};
+
+my $cq;
+
+my $module = delete $opts{module};
+
+$cq = Clearquest->new (%opts);
+
+$cq->connect;
+
+# Fix key if necessary
+if ($key =~ /^(\d+)$/) {
+ $key = $cq->{database} . 0 x (8 - length $1) . $1;
+} # if
+
+my %record = $cq->get ($record, $key, @fields);
+
+unless ($cq->error) {
+ foreach my $field (sort keys %record) {
+ if (ref $record{$field} eq 'ARRAY') {
+ display "$field (LIST):";
+
+ display "\t$_" foreach (@{$record{$field}});
+ } else {
+ display_nolf "$field: ";
+
+ if ($record{$field}) {
+ display $record{$field};
+ } else {
+ display '<undef>';
+ } # if
+ } # if
+ } # foreach
+
+ exit 0;
+} else {
+ error "Unable to get $record with key $key\n" . $cq->errmsg, $cq->error;
+} # unless
--- /dev/null
+#!/usr/bin/perl
+use strict;
+use warnings;
+
+=pod
+
+=head1 NAME $RCSfile: cqquery.pl,v $
+
+Clearquest Query
+
+This command line tool allows for a simplified access to Clearquest database
+and supports an SQL like syntax to allow you to select and update data quickly.
+It has the ability to talk to a running Clearquest::Server process so you can
+use it on systems that do not have Clearques installed.
+
+Currently the command langauge is limited - no joins or multiple tables, only
+very simple where conditions, etc. This may improve over time.
+
+All actions are logged to cqquery.log.
+
+Note that CmdLine is in use so you have a fully command history stack (subject,
+of course, to whether or not you have Term::ReadLine::Gnu installed. For cqperl
+that's a no go. For Cygwin's Perl or Linux based Perl's you do or can install it
+from CPAN) as well as CmdLine builtins like history and help.
+
+Control-C handling is also supported.
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.3 $
+
+=item Created:
+
+Mon Oct 24 16:19:15 PDT 2011
+
+=item Modified:
+
+$Date: 2012/12/18 19:44:10 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage: cqquery [-u|sage] [-v|erbose] [-d|ebug]
+ [-username <username>] [-password <password>]
+ [-database <database>] [-dbset <dbset>]
+ [-histfile <histfile>]
+ [-[no]c|qd]
+
+ Where:
+ -usa|ge: Displays usage
+ -v|erbose: Be verbose
+ -de|bug: Output debug messages
+
+ -h|istfile <histfile>: History file to use
+
+ -use|rname <username>: Username name to use
+ -p|assword <password>: Password to use
+ -da|tabase <database>: Database to use
+ -db|set <dbset>: DB Set to use
+ -[no]c|qd: If set then look for a Clearquest::Server
+
+=head1 FILES
+
+Configuration data is stored in ../etc/cqdservice.conf which defines the
+defaults for things like username/password/db, etc. These are overridden by the
+environent (-username is CQD_USERNAME, -password is CQDPASSWORD, etc. for
+server based connections, CQ_USERNAME, CQPASSWORD, etc. for direct connections).
+Command line options (e.i. -username) override both the environment and the
+config file.
+
+=cut
+
+# TODO: This needs major revision...
+
+use FindBin;
+use Term::ANSIColor;
+use Getopt::Long;
+
+use lib "$FindBin::Bin/../lib";
+
+use CmdLine;
+use Display;
+use Logger;
+use Utils;
+
+my $VERSION = '$Revision: 1.3 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+my %cmds = (
+ select => {
+ help => 'select <fields> from <table> [where <condition>]',
+ description => 'Selects fields from a table with an optional condiiton.
+Currently conditions are limited.
+',
+ },
+
+ update => {
+ help => 'update <table> set <field> = <expr> [where <condition>]',
+ description => 'Update a field in a table based on an optional condition',
+ },
+
+ insert => {
+ help => 'insert [into] <table> <fields> values <values>',
+ description => 'Insert a new record into table',
+ },
+
+ delete => {
+ help => 'delete [from] <table> [where <condition>]',
+ description => 'Delete records from table based on condition (not implemented)',
+ },
+);
+
+my (%opts, $cq, $log, $pipe);
+
+sub interrupt () {
+ display_nolf
+ color ('yellow')
+ . '<Control-C>'
+ . color ('reset')
+ . '... '
+ . color ('red')
+ . "Abort current operation (y/N)?"
+ . color ('reset');
+
+ my $response = <STDIN>;
+ chomp $response;
+
+ die "Operation aborted\n" if $response =~ /^\s*(y|yes)/i;
+
+ display color ('cyan') . 'Continuing...' . color ('reset');
+} # interrupt
+
+sub pipeInterrupt () {
+ StopPipe $pipe;
+
+ undef $pipe;
+} # pipeInterrupt
+
+sub findRecords ($$;@) {
+ my ($table, $condition, @fields) = @_;
+
+ my ($result, $nbrRecs) = $cq->find ($table, $condition, @fields);
+
+ $nbrRecs ||= 0;
+
+ my $msg = "$nbrRecs records qualified";
+
+ $SIG{PIPE} = \&pipeInterrupt;
+
+ $pipe = StartPipe $ENV{PAGER};
+
+ PipeOutput $msg, $pipe;
+
+ $log->log ($msg);
+
+ return ($result, $nbrRecs);
+} # findRecords
+
+sub select ($$@) {
+ my ($table, $condition, @fields) = @_;
+
+ my ($result, $nbrRecs) = findRecords ($table, $condition, @fields);
+
+ if ($cq->errnbr) {
+ error $result;
+
+ return;
+ } # if
+
+ while (my %record = $cq->getNext ($result)) {
+ last unless $pipe;
+
+ foreach (@fields) {
+ last unless $pipe;
+
+ my $line = $record{$_} ? "$_: $record{$_}" : "$_ <undef>";
+
+ $log->log ($line);
+
+ PipeOutput $line, $pipe;
+ } # foreach
+ } # while
+
+ StopPipe $pipe;
+
+ undef $pipe;
+} # select
+
+sub update ($$%) {
+ my ($table, $condition, %update) = @_;
+
+ my ($result, $nbrRecs) = findRecords ($table, $condition);
+
+ if ($cq->errnbr) {
+ error $result;
+
+ return;
+ } # if
+
+ $nbrRecs ||= 0;
+
+ $log->disp ("$nbrRecs records qualified");
+
+ my ($processed, $updated) = (0, 0);
+
+ while (my %record = $cq->getNext ($result)) {
+ $processed++;
+
+ my $key = $cq->key ($table, $record{dbid});
+
+ $log->disp ("Updating $key", 1);
+
+ my $errmsg = $cq->updateRec ($table, $record{dbid}, %update);
+
+ if ($errmsg ne '') {
+ $log->disp (color ('red') . ' failed!!' . color ('reset'));
+ $log->incrementErr;
+ $log->log ($errmsg);
+ } else {
+ $log->disp (color ('green' ). ' succeeded.' . color ('reset'));
+
+ $updated++;
+ } # if
+ } # while
+
+ my $errors = $log->errors;
+
+ return unless $processed;
+
+ my $msg;
+
+ $msg = $processed;
+
+ if ($processed == 1) {
+ $log->disp ('One record processed');
+ } else {
+ $log->disp ("$processed records processed");
+ } # if
+
+ if ($updated == 1) {
+ $log->disp ('One record updated');
+ } else {
+ $log->disp ("$updated records updated");
+ } # if
+
+ if ($errors == 1) {
+ $log->disp ('One error (Check ' . $log->fullname . ' for more info)');
+ } elsif ($errors > 1) {
+ $log->disp ("$errors errors (Check " . $log->fullname . ' for more info)');
+ } else {
+ $log->disp ("$errors errors");
+ } # if
+} # update
+
+sub insert ($%) {
+ my ($table, %values) = @_;
+
+ my $errmsg = $cq->insert ($table, %values);
+
+ if ($errmsg ne '') {
+ $log->err ("Unable to insert record:\n$errmsg");
+ } else {
+ $log->disp ("Inserted record");
+ } # if
+} # insert
+
+sub evaluate ($) {
+ my ($line) = @_;
+
+ my @fields;
+
+ # Mimic simple SQL statements...
+ if ($line =~ /^\s*select\s+([\w, ]+)\s+from\s+(\S+)(.*)\;*/i) {
+ my ($table, $condition, $rest);
+
+ @fields = split (/\s*,\s*/, $1);
+ $table = $2;
+ $rest = $3;
+
+ # Trim any trailing ';' from table in case the person didn't enter a where
+ # clause
+ $table =~ s/\;$//;
+
+ if ($rest =~ /\s*where\s+(.*?)\;*$/i) {
+ $condition = $1;
+ } elsif ($rest !~ /^\s*$/) {
+ error "Syntax error in select statement\n\n\t$line";
+
+ return 1;
+ } # if
+
+ return ::select ($table, $condition, @fields);
+ } elsif ($line =~ /^\s*update\s+(\S+)\s+set\s+(\S+)\s*=\s*(.*)/i) {
+ my ($table, $condition, %update, $rest);
+
+ $table = $1;
+ $rest = $3;
+
+ my $fieldName = $2;
+
+ my $value;
+
+ if ($rest =~ /(.*)\s+where\s+(.*)/) {
+ $value = $1;
+ $condition = $2;
+ } else {
+ $value = $rest;
+ } # if
+
+ # Fix up $value;
+ $value =~ s/^\s*["'](.*)/$1/;
+ $value =~ s/(.*)["']\s*$/$1/;
+
+ $update{$fieldName} = $value;
+
+ return update ($table, $condition, %update);
+ } elsif ($line =~ /^\s*insert\s+(into)*\s+(\S+)\s+([\w, ]+)\s+values*\s+([\w, ]+)\;*/i) {
+ my ($table, @values);
+
+ $table = $2;
+ @fields = split /\s*,\s*/, $3;
+ @values = split /\s*,\s*/, $4;
+
+ my %values;
+
+ $values{$_} = shift @values foreach (@fields);
+
+ return ::insert ($table, %values);
+ } elsif ($line =~/^\s*shutdown\s*$/) {
+ $cq->shutdown;
+
+ exit;
+ } elsif ($line =~ /^\s*$/) {
+ return;
+ } else {
+ $log->err ("Unknown command: $line");
+
+ return 1;
+ } # if
+} # evaluate
+
+## Main
+$| = 1;
+
+# Use test database for now...
+$opts{database} = 'mobct';
+$opts{histfile} = $ENV{CQQUERY_HISTFILE} || "./${FindBin::Script}_hist";
+$opts{cqd} = 1;
+
+GetOptions (
+ \%opts,
+ usage => sub { Usage },
+ verbose => sub { set_verbose },
+ debug => sub { set_debug },
+ 'cqd!',
+ 'username=s',
+ 'database=s',
+ 'password=s',
+ 'histfile=s',
+ 'dbset=s',
+) || Usage;
+
+display "$FindBin::Script v$VERSION";
+
+$SIG{INT} = \&interrupt;
+
+if ($opts{cqd}) {
+ require Clearquest::Client;
+ $cq = Clearquest::Client->new (%opts);
+} else {
+ require Clearquest;
+ $cq = Clearquest->new (\%opts);
+} # if
+
+$log = Logger->new;
+
+my $me = $FindBin::Script;
+ $me =~ s/\.pl$//;
+
+my $prompt = color ('bold green') . "$me:" . color ('reset');
+$prompt="$me:";
+
+$CmdLine::cmdline->set_histfile ($opts{histfile});
+$CmdLine::cmdline->set_prompt ($prompt);
+$CmdLine::cmdline->set_cmds (%cmds);
+$CmdLine::cmdline->set_eval (\&evaluate);
+
+my ($line, $result);
+
+my $dbconnection = $cq->username . '@' . $cq->database . '/' . $cq->dbset;
+ $dbconnection .= ' (Server: ' . $cq->host . ':' . $cq->port . ')'
+ if ref $cq eq 'Clearquest::Client';
+
+my $msg = "Opening database $dbconnection";
+
+verbose_nolf color ('dark white') . "$msg..." . color ('reset');
+$log->log ($msg, 1);
+
+unless ($cq->connect) {
+ $log->msg (color ('red') . ' Failed!' . color ('reset'));
+
+ $log->err ("Unable to connect to database $dbconnection", 1);
+} else {
+ verbose color ('dark white') . ' connected' . color ('reset');
+ $log->log (' connected');
+} # unless
+
+# Single execution from command line
+if ($ARGV[0]) {
+ my $result = evaluate join ' ', @ARGV;
+
+ $result ||= 1;
+
+ exit $result;
+} # if
+
+while (($line, $result) = $CmdLine::cmdline->get ()) {
+ last unless defined $line;
+
+ $log->log ("$me: $line");
+
+ last if $line =~ /exit|quit/i;
+
+ my $result = evaluate ($line);
+} # while
+
+$cq->disconnect;
+
+exit;
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: enable_ldap
+# Description: This script enables LDAP Authentication on a DB set. LDAP
+# Authentication is supported in Clearquest 2003.06.15 and higher.
+#
+# Author: Andrew@DeFaria.com
+# Created: Fri Sep 23 17:27:58 PDT 2005
+# Language: Perl
+# Modules: Term::ReadLine, Term::ReadKey
+#
+# (c) Copyright 2005, Andrew@DeFaria.com, all rights reserved
+#
+################################################################################
+use strict;
+use warnings;
+use Term::ReadLine;
+use Term::ReadKey;
+
+$0 =~ /(.*)[\/\\](.*)/;
+my $me = (!defined $2) ? $0 : $2;
+
+my $execute = 1;
+my $verbose = 0;
+
+sub Usage {
+ my $msg = shift;
+
+ print "ERROR: $msg\n" if defined $msg;
+
+ print "Usage: $me [-n] [-v] [-u]
+
+Where:
+
+ -n: No execute mode (Default Execute)
+ -v: Turn on verbose mode (Default off)
+ -f: Configuration file (Default ldap_settings.cfg)
+ -u: Display this usage
+";
+
+ exit 1;
+} # Usage
+
+sub verbose {
+ my $msg = shift;
+
+ print "$msg" if $verbose;
+} # verbose
+
+sub error {
+ my $msg = shift;
+ my $errno = shift;
+
+ if (!defined $errno) {
+ $msg = "$me: ERROR: $msg";
+ } else {
+ $msg = "$me: ERROR: #$errno: $msg"
+ } # if
+
+ print $msg;
+
+ exit $errno if defined $errno;
+} # error
+
+sub DisplayLDAPParms {
+ my %ldap_parms = @_;
+
+ print "\nLDAP Parms:\n";
+
+ foreach (sort (keys (%ldap_parms))) {
+ if (/password/) {
+ print "$_: <password>\n";
+ } else {
+ print "$_: ${ldap_parms {$_}}\n";
+ } # if
+ } # foreach
+} # DisplayLDAPParms
+
+sub ParseSettings {
+ my $config_file = shift;
+
+ my %ldap_parms;
+
+ open SETTINGS, $config_file
+ or error "Unable to open $config_file ($!)", 1;
+
+ while (<SETTINGS>) {
+ chomp; chop if /\r/;
+
+ next if /^$/; # Skip blank lines
+ next if /^\#/; # and comments
+
+ if (/^dbset:\s*(.*)/i) {
+ $ldap_parms{dbset} = $1;
+ } elsif (/^admin_username:\s*(.*)/i) {
+ $ldap_parms{admin_username} = $1;
+ } elsif (/^admin_password:\s*(.*)/i) {
+ $ldap_parms{admin_password} = $1;
+ } elsif (/^servers:\s*(.*)/i) {
+ $ldap_parms{servers} = $1;
+ } elsif (/^port:\s*(.*)/i) {
+ $ldap_parms{port} = $1;
+ } elsif (/^port:\s*(.*)/i) {
+ $ldap_parms{port} = $1;
+ } elsif (/^search_distinguished_name:\s*(.*)/i) {
+ $ldap_parms{search_distinguished_name} = $1;
+ } elsif (/^search_password:\s*(.*)/i) {
+ $ldap_parms{search_password} = $1;
+ } elsif (/^basedn:\s*(.*)/i) {
+ $ldap_parms{basedn} = $1;
+ } elsif (/^scope:\s*(.*)/i) {
+ $ldap_parms{scope} = $1;
+ } elsif (/^account_attribute:\s*(.*)/i) {
+ $ldap_parms{account_attribute} = $1;
+ } elsif (/^search_filter:\s*(.*)/i) {
+ $ldap_parms{search_filter} = $1;
+ } elsif (/^cq_field:\s*(.*)/i) {
+ $ldap_parms{cq_field} = $1;
+ } elsif (/^attribute_search_entry:\s*(.*)/i) {
+ $ldap_parms{attribute_search_entry} = $1;
+ } elsif (/^test_username:\s*(.*)/i) {
+ $ldap_parms{test_username} = $1;
+ } # if
+ } # while
+
+ close SETTINGS;
+
+ return %ldap_parms;
+} # ParseSettings
+
+sub Prompt {
+ my $prefix = shift; # Prefix or question being asked
+ my $default = shift; # default value - if any
+ my $suffix = shift; # Suffix (default ":")
+ my $password = shift; # Whether or not to turn off echo (default "no");
+
+ $default = "" if !defined $default;
+ $suffix = ":" if !defined $suffix;
+ $password = "no" if !defined $password;
+
+ my $value;
+
+ do {
+ print "\n$prefix";
+ print " [$default]" if $default ne "" and $password ne "yes";
+ print "$suffix ";
+
+ if ($password eq "yes") {
+ ReadMode "noecho";
+ $value = ReadLine (0);
+ ReadMode "normal";
+ } else {
+ $value = <STDIN>;
+ } # if
+
+ chomp $value;
+ $value = $default if $value eq "";
+ } until $value ne "";
+
+ return $value
+} # Prompt
+
+sub SaveSettings {
+ my $config_file = shift;
+ my %ldap_parms = @_;
+
+ open SETTINGS, ">$config_file"
+ or error "Unable to open $config_file ($!)", 2;
+
+ foreach (sort (keys (%ldap_parms))) {
+ if ($_ eq "cq_field") {
+ my $value = "";
+ $value = "CQ_EMAIL" if $ldap_parms {$_} eq "1";
+ $value = "CQ_FULLNAME" if $ldap_parms {$_} eq "2";
+ $value = "CQ_LOGIN_NAME" if $ldap_parms {$_} eq "3";
+ $value = "CQ_MISC_INFO" if $ldap_parms {$_} eq "4";
+ $value = "CQ_PHONE" if $ldap_parms {$_} eq "5";
+ print SETTINGS "$_:\t$value\n" if $value ne "";
+ } else {
+ print SETTINGS "$_:\t${ldap_parms {$_}}\n";
+ } # if
+ } # foreach
+
+ close SETTINGS;
+} # SaveSettings
+
+sub GetLDAPParms {
+ my %ldap_parms = @_;
+
+ print "DBSET name: This is the name of the Clearquest database set - also
+known as database connection name. This can be found in the Clearquest
+Maintainance Tool. Often this is something like \"2003.06.15\".
+";
+
+ $ldap_parms {dbset} = Prompt "What is the DBSET name that you wish to enable LDAP on", $ldap_parms {dbset};
+
+ print "
+Now we need to know the username and password of the administrative
+user for the $ldap_parms{dbset} DBSET:
+";
+
+ $ldap_parms {admin_username} = Prompt "Admin username", $ldap_parms {admin_username};
+ $ldap_parms {admin_password} = Prompt "${ldap_parms {admin_username}}'s password", $ldap_parms {admin_password}, undef, "yes";
+
+ # A: LDAP Server
+ print "\nA: LDAP Server\n";
+ print "
+Now we need to know the name of the LDAP server to authenticate to.
+
+What is the host name of the LDAP server? You can specify multiple
+hosts so that ClearQuest can attempt to connect to an alternate host
+if it cannot connect to the first one.
+
+You can specify multiple servers separated by commas.
+";
+
+ $ldap_parms {servers} = Prompt "LDAP Server(s)", $ldap_parms {servers};
+
+ # B: LDAP Port
+ print "\nB: LDAP Port\n";
+ print "
+What is the TCP port number (non-SSL) where the LDAP server listens
+for communications?
+";
+
+ $ldap_parms {port} = Prompt "LDAP port", $ldap_parms {port};
+
+ # C: LDAP Search Username/Password
+ print "\nC: LDAP Distinguished Name for Search Account/Password\n";
+ print "\nDoes the LDAP server allow anonymous searches (Y/n)? ";
+ $_ = <STDIN>; chomp;
+
+ if ($_ !~ /^y|^yes|^$/i) {
+ # C1: LDAP Search username
+ print "
+What is the distinguished name (DN) of the search account?
+
+For example: cn=search_user,cn=Users, dc=cqldapmsft,dc=com
+";
+
+ $ldap_parms {search_distinguished_name} = Prompt "ClearQuest users. LDAP Search user name", $ldap_parms {search_distinguished_name};
+
+ # C2: LDAP Search passwrod
+ $ldap_parms {search_password} = Prompt "Password", $ldap_parms {search_password}, undef, "yes";
+ } # if
+
+ # D: LDAP BaseDN
+ print "\nD: LDAP BaseDN\n";
+ print "
+Now here's where things get tricky. LDAP uses a BaseDN or Base
+Distinguished Name as a sort of path into the LDAP directory. Your
+LDAP Administrator should be able to provide you with this
+information.
+
+What is the base DN from which to start searching for LDAP user
+directory entries that correspond to ClearQuest users? The base DN
+must be high enough in the directory hierarchy to include all users
+that might need to be authenticated; however, a base DN that is too
+high in the hierarchy might slow login performance.
+";
+
+ $ldap_parms {basedn} = Prompt "LDAP BaseDN", $ldap_parms {basedn};
+
+ # E: LDAP Scope
+ while (!defined $ldap_parms {scope} or
+ ($ldap_parms {scope} ne "sub" and
+ $ldap_parms {scope} ne "one" and
+ $ldap_parms {scope} ne "base")) {
+ print "\nE: LDAP Scope\n";
+ print "
+What is the scope of the search from the base DN?: sub (subtree); one
+(one level below); or base (base DN only).
+";
+
+ $ldap_parms {scope} = Prompt "LDAP Scope [sub|one|base]", $ldap_parms {scope};
+ } # while
+
+ # F: LDAP Account Attribute
+ print "\nF: LDAP Account Attribute\n";
+ print "
+What is the LDAP attribute that is used to store the user entry login
+name values? ClearQuest uses the text string entered in the ClearQuest
+Login window to search the LDAP directory for a user entry whose LDAP
+attribute value matches the login name. This LDAP attribute must store
+unique values for all user entries that ClearQuest searches. You also
+use this attribute in the answer to the next question.
+
+For example: samAccountName
+";
+
+ $ldap_parms {account_attribute} = Prompt "LDAP Account Attribute", $ldap_parms {account_attribute};
+
+ # G: LDAP Search Filter
+ print "\nG: LDAP Search Filter\n";
+ print "
+What is the LDAP search filter that ClearQuest must use to select the
+LDAP user entry based on the attribute specified in the previous
+question? Use \%login\% as the user's login name; ClearQuest substitutes
+the text string the user enters in the ClearQuest login window.
+
+For example: ${ldap_parms {account_attribute}}=\%login\%
+";
+
+ $ldap_parms {search_filter} = Prompt "LDAP Search Filter", $ldap_parms {search_filter};
+
+ # H: LDAP Attribute Search Entry
+ print "\nH: LDAP Attribute Search Entry\n";
+ print "
+What is the LDAP attribute of the user entry to be used to map the
+user to a corresponding ClearQuest user profile record? You can map an
+attribute to one of the following ClearQuest user profile record
+fields: CQ_EMAIL, CQ_FULLNAME, CQ_LOGIN_NAME, CQ_MISC_INFO, or
+CQ_PHONE. The ClearQuest administrator and LDAP administrator need to
+work together to determine this mapping.
+
+First specify the Clearquest field you wish to map to:
+
+1) CQ_EMAIL
+2) CQ_FULLNAME
+3) CQ_LOGIN_NAME
+4) CQ_MISC_INFO
+5) CQ_PHONE
+";
+
+ my $default_cq_field;
+
+ if ($ldap_parms {cq_field} eq "CQ_EMAIL") {
+ $default_cq_field = 1;
+ } elsif ($ldap_parms {cq_field} eq "CQ_FULLNAME") {
+ $default_cq_field = 2;
+ } elsif ($ldap_parms {cq_field} eq "CQ_LOGIN_NAME") {
+ $default_cq_field = 3;
+ } elsif ($ldap_parms {cq_field} eq "CQ_MISC_INFO") {
+ $default_cq_field = 4;
+ } elsif ($ldap_parms {cq_field} eq "CQ_PHONE") {
+ $default_cq_field = 5;
+ } else {
+ $default_cq_field = 0;
+ } # if
+
+ do {
+ $ldap_parms {cq_field} = Prompt "Enter choice (1-5)", $default_cq_field;
+ } until ($ldap_parms {cq_field} > 0 and $ldap_parms {cq_field} < 6);
+
+ print "\nH: LDAP Attribute Search Entry\n";
+ print "
+Now enter the corresponding LDAP field that this maps to.
+";
+
+ $ldap_parms {attribute_search_entry} = Prompt "LDAP Attribute Search Entry", $ldap_parms {attribute_search_entry};
+
+ # I: LDAP Test Username
+ print "\nI: LDAP Test Username\n";
+ print "
+What is the login name of a user entry that can be used to validate
+that ClearQuest can correctly authenticate a user against the LDAP
+directory? This can be a test account or an actual user account.
+";
+
+ $ldap_parms {test_username} = Prompt "LDAP Test Username", $ldap_parms {test_username};
+
+ # J: LDAP Test Password
+ print "\nJ: LDAP Test Password\n";
+ print"
+What is the password for the user entry specified in the previous
+question?
+";
+
+ $ldap_parms {test_password} = Prompt "LDAP Test Password", $ldap_parms {test_password}, undef, "yes";
+
+ return %ldap_parms;
+} # GetLDAPParms
+
+sub SetAuthentication2CQOnly {
+ my %ldap_parms = @_;
+
+ my $cmd = "installutil setauthenticationalgorithm " .
+ $ldap_parms {dbset} . " " .
+ $ldap_parms {admin_username} . " " .
+ $ldap_parms {admin_password} . " " .
+ "CQ_ONLY";
+
+ verbose "$cmd\n";
+
+ return if !$execute;
+
+ my @output = `$cmd`;
+
+ if ($? ne 0) {
+ print "Error executing $cmd\n";
+
+ foreach (@output) {
+ print $_;
+ } # foreach
+
+ exit 1;
+ } # if
+} # SetAuthentication2CQOnly
+
+sub SetLDAPInit {
+ my %ldap_parms = @_;
+
+ my $cmd = "installutil setldapinit " .
+ $ldap_parms {dbset} . " " .
+ $ldap_parms {admin_username} . " " .
+ $ldap_parms {admin_password} . " \"" .
+ "-h " . $ldap_parms {servers} . " " .
+ "-p " . $ldap_parms {port};
+
+ if (defined $ldap_parms {search_distinguished_name}) {
+ $cmd .= " -D " . $ldap_parms {search_distinguished_name} .
+ " -w " . $ldap_parms {search_password};
+ } # if
+
+ $cmd .= "\"";
+
+ verbose "$cmd\n";
+
+ return if !$execute;
+
+ my @output = `$cmd`;
+
+ if ($? ne 0) {
+ print "Error executing $cmd\n";
+
+ foreach (@output) {
+ print $_;
+ } # foreach
+
+ exit 1;
+ } # if
+} # SetLDAPInit
+
+sub SetLDAPSearch {
+ my %ldap_parms = @_;
+
+ my $cmd = "installutil setldapsearch " .
+ $ldap_parms {dbset} . " " .
+ $ldap_parms {admin_username} . " " .
+ $ldap_parms {admin_password} . " \"" .
+ "-s " . $ldap_parms {scope} . " " .
+ "-b " . $ldap_parms {basedn} . " " .
+ $ldap_parms {search_filter} . "\"";
+
+ print "$cmd\n";
+ return;
+
+ my @output = `$cmd`;
+
+ if ($? ne 0) {
+ print "Error executing $cmd\n";
+
+ foreach (@output) {
+ print $_;
+ } # foreach
+
+ exit 1;
+ } # if
+} # SetLDAPSearch
+
+sub MapLDAPFields {
+ my %ldap_parms = @_;
+
+ my @cq_fields = (
+ "CQ_EMAIL",
+ "CQ_FULLNAME",
+ "CQ_LOGIN_NAME",
+ "CQ_MISC_INFO",
+ "CQ_PHONE",
+ );
+
+ my $cq_field = $cq_fields [($ldap_parms {cq_field} - 1)];
+
+ my $cmd = "installutil setcqldapmap " .
+ $ldap_parms {dbset} . " " .
+ $ldap_parms {admin_username} . " " .
+ $ldap_parms {admin_password} . " " .
+ $cq_field . " " .
+ $ldap_parms {attribute_search_entry};
+
+ verbose "$cmd\n";
+
+ return if !$execute;
+
+ my @output = `$cmd`;
+
+ if ($? ne 0) {
+ print "Error executing $cmd\n";
+
+ foreach (@output) {
+ print $_;
+ } # foreach
+
+ exit 1;
+ } # if
+} # MapLDAPFields
+
+sub ValidateLDAPConfig {
+ my %ldap_parms = @_;
+
+ my $cmd = "installutil validateldap " .
+ $ldap_parms {dbset} . " " .
+ $ldap_parms {admin_username} . " " .
+ $ldap_parms {admin_password} . " " .
+ $ldap_parms {test_username} . " " .
+ $ldap_parms {test_password};
+
+ verbose "$cmd\n";
+
+ return if !$execute;
+
+ my @output = `$cmd`;
+
+ if ($? ne 0) {
+ print "Error executing $cmd\n";
+
+ foreach (@output) {
+ print $_;
+ } # foreach
+
+ exit 1;
+ } # if
+
+} # ValidateLDAPConfig
+
+sub SetAuthentication2CQFirst {
+ my %ldap_parms = @_;
+ my $cmd = "installutil setauthenticationalgorithm " .
+ $ldap_parms {dbset} . " " .
+ $ldap_parms {admin_username} . " " .
+ $ldap_parms {admin_password} . " " .
+ "CQ_FIRST";
+
+ verbose "$cmd\n";
+
+ return if !$execute;
+
+ my @output = `$cmd`;
+
+ if ($? ne 0) {
+ print "Error executing $cmd\n";
+
+ foreach (@output) {
+ print $_;
+ } # foreach
+
+ exit 1;
+ } # if
+} # SetAuthentication2CQFirst
+
+my $config_file = "ldap_settings.cfg";
+
+while ($ARGV [0]) {
+ if ($ARGV [0] eq "-v") {
+ $verbose = 1;
+ } elsif ($ARGV [0] eq "-n") {
+ $execute = 0;
+ } elsif ($ARGV [0] eq "-u") {
+ Usage;
+ } elsif ($ARGV [0] eq "-f") {
+ shift;
+ if ($ARGV [0] eq "") {
+ Usage "Must specify config file after -f";
+ } # if
+ $config_file = $ARGV [0];
+ } else {
+ Usage "Unknown argument found: " . $ARGV [0];
+ } # if
+
+ shift (@ARGV);
+} # while
+
+my %ldap_parms = ParseSettings $config_file;
+
+print "$me: Enable Clearquest LDAP Authentication on a dbset
+
+First we need to ask some questions...
+
+";
+
+%ldap_parms = GetLDAPParms %ldap_parms;
+
+DisplayLDAPParms %ldap_parms;
+
+print "Proceed (Y/n)? ";
+$_ = <STDIN>; chomp;
+
+if ($_ =~ /^y|^yes/i) {
+ print "OK, quitting...\n";
+ exit 1;
+} # if
+
+if (-f $config_file) {
+ print "Save settings overwriting $config_file (y/N)? ";
+ $_ = <STDIN>; chomp;
+
+ if ($_ =~ /^y|^yes/i) {
+ SaveSettings $config_file, %ldap_parms;
+ } # if
+} else {
+ SaveSettings $config_file, %ldap_parms;
+} # if
+
+SetAuthentication2CQOnly %ldap_parms;
+SetLDAPInit %ldap_parms;
+SetLDAPSearch %ldap_parms;
+MapLDAPFields %ldap_parms;
+ValidateLDAPConfig %ldap_parms;
+SetAuthentication2CQFirst %ldap_parms;
--- /dev/null
+#################################################################################
+#
+# File: ldap_settings.cfg
+# Description: Describes the various LDAP parameters
+# Author: Andrew@DeFaria.com
+# Created: Wed Nov 2 11:19:04 PST 2005
+# Language: None
+#
+# (c) Copyright 2005, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+DBSet: 2005.02.00
+Admin_username: admin
+#Admin_password:
+Servers: stupid_server_at.sexy.broads.com
+Port: 389
+Search_distinguished_name: cn=china,cn=Users,dc=washington,dc=ad,dc=sexy.broads,dc=com
+#Search_password:
+BaseDN: dc=corp,dc=ad,dc=sexy.broads,dc=com
+Scope: sub
+Account_attribute: samAccountName
+Search_filter: samAccountName=%login%
+CQ_field: CQ_LOGIN_NAME
+attribute_search_entry: samAccountName
+Test_username: adefaria
+#Test_password:
\ No newline at end of file
--- /dev/null
+#!cqperl
+################################################################################
+#
+# File: listdynlists
+# Description: This script lists the dynamic lists in the database...
+#
+# Author: Andrew@DeFaria.com
+# Created: Fri Sep 23 17:27:58 PDT 2005
+# Language: Perl
+#
+# (c) Copyright 2005, Andrew@DeFaria.com, all rights reserved
+#
+################################################################################
+use strict;
+use warnings;
+use CQPerlExt;
+use File::Spec;
+
+our ($me, $SEPARATOR);
+
+my ($abs_path, $lib_path);
+
+BEGIN {
+ # Extract relative path and basename from script name.
+ $0 =~ /(.*)[\/\\](.*)/;
+
+ $abs_path = (!defined $1) ? "." : File::Spec->rel2abs ($1);
+ $me = (!defined $2) ? $0 : $2;
+ $me =~ s/\.pl$//;
+
+ # Remove .pl for Perl scripts that have that extension
+ $me =~ s/\.pl$//;
+
+ # Define the path SEPARATOR
+ $SEPARATOR = ($^O =~ /MSWin/) ? "\\" : "/";
+
+ # Setup paths
+ $lib_path = "$abs_path" . $SEPARATOR . ".." . $SEPARATOR . "lib";
+
+ # Add the appropriate path to our modules to @INC array.
+ unshift (@INC, "$abs_path");
+ unshift (@INC, "$lib_path");
+} # BEGIN
+
+use PQA;
+use Display;
+
+my @dynamic_lists = (
+ "Advanced_Feature",
+ "Board_Revision",
+ "HUT",
+ "HUT_Revision",
+ "OS",
+ "OS_Service_Pack",
+ "Other_HUT",
+ "Project",
+ "Reported_By",
+ "Software",
+ "Visibility",
+);
+
+my $to_db_connection_name = "2005.02.00";
+my $controller = StartSession "Cont", $to_db_connection_name;
+
+foreach (@dynamic_lists) {
+ display "\nDynamic List: $_";
+ my @values = @{$controller->GetListMembers ($_)};
+ my $i = 0;
+
+ foreach (@values) {
+ display "\t" . ++$i . ") $_";
+ } # foreach
+} # foreach
+
+EndSession $controller;
--- /dev/null
+#!cqperl
+################################################################################
+#
+# File: pqaclean
+# Description: Cleans destination PQA Cont database by removing all defects
+# then Customer and Project stateless records. Useful when
+# debugging and performing multiple runs of pqamerge.
+#
+# Author: Andrew@DeFaria.com
+# Created: Fri Sep 23 17:27:58 PDT 2005
+# Language: Perl
+#
+# (c) Copyright 2005, Andrew@DeFaria.com, all rights reserved
+#
+################################################################################
+use strict;
+use warnings;
+use CQPerlExt;
+use File::Spec;
+
+our ($me, $SEPARATOR);
+
+my ($abs_path, $lib_path);
+
+BEGIN {
+ # Extract relative path and basename from script name.
+ $0 =~ /(.*)[\/\\](.*)/;
+
+ $abs_path = (!defined $1) ? "." : File::Spec->rel2abs ($1);
+ $me = (!defined $2) ? $0 : $2;
+ $me =~ s/\.pl$//;
+
+ # Remove .pl for Perl scripts that have that extension
+ $me =~ s/\.pl$//;
+
+ # Define the path SEPARATOR
+ $SEPARATOR = ($^O =~ /MSWin/) ? "\\" : "/";
+
+ # Setup paths
+ $lib_path = "$abs_path" . $SEPARATOR . ".." . $SEPARATOR . "lib";
+
+ # Add the appropriate path to our modules to @INC array.
+ unshift (@INC, "$abs_path");
+ unshift (@INC, "$lib_path");
+} # BEGIN
+
+use PQA;
+use Display;
+use Logger;
+use TimeUtils;
+
+my $from_db_connection_name = "2005.02.00";
+
+sub Usage {
+ my $msg = shift;
+
+ display "ERROR: $msg\n" if defined $msg;
+
+ display "Usage: $me\t[-u] [-v] [-d] [-from <connection name>]
+
+Where:
+ -u: Display usage
+ -v: Turn on verbose mod
+ -d: Turn on debug mode
+ -from <connection_name>: Specify the from connaction name
+ (Default $from_db_connection_name)";
+ exit 1;
+} # Usage
+
+
+my $log = Logger->new (path => ".");
+
+while ($ARGV [0]) {
+ if ($ARGV [0] eq "-v") {
+ Display::set_verbose;
+ Logger::set_verbose;
+ } elsif ($ARGV [0] eq "-d") {
+ set_debug;
+ } elsif ($ARGV [0] eq "-from") {
+ shift;
+ if (!$ARGV [0]) {
+ Usage "Must specify <connection name> after -from";
+ } else {
+ $from_db_connection_name = $ARGV [0];
+ } # if
+ } elsif ($ARGV [0] eq "-u") {
+ Usage;
+ } else {
+ Usage "Unknown argument found: " . $ARGV [0];
+ } # if
+
+ shift (@ARGV);
+} # while
+
+my $process_start_time = time;
+my $controller = StartSession "Cont", $from_db_connection_name;
+$log->msg ("Opened Controller (Cont) database from \"$from_db_connection_name\" connection");
+
+my $start_time;
+
+$start_time = time;
+DeleteRecords $log, $controller, "defect";
+display_duration $start_time, $log;
+
+$start_time = time;
+DeleteRecords $log, $controller, "Customer";
+display_duration $start_time, $log;
+
+$start_time = time;
+DeleteRecords $log, $controller, "Project";
+display_duration $start_time, $log;
+
+$start_time = time;
+DeleteDynamicLists $log, $controller;
+display_duration $start_time, $log;
+
+EndSession $controller;
+display_duration $process_start_time, $log;
--- /dev/null
+#!cqperl
+################################################################################
+#
+# File: pqamerge
+# Description: Merge the old TO (Teton) and Prod databases to the new Cont
+# (Controller) database. This process assumes the new database
+# is empty and that there are two "masterdb"'s named From and To.
+# These are Clearquest connection profiles and From and To refer
+# to the names given in the Clearquest Maintainance Tool for the
+# connections. From contains both the TO and Prod databases and
+# the To connection contains the Cont database.
+#
+# Note that it is also assumed that the Cont database has had it's
+# code page set to US ASCII. This script will translate non US
+# ASCII characters in the from databases to HTML equivalents.
+#
+# Author: Andrew@DeFaria.com
+# Created: Fri Sep 23 17:27:58 PDT 2005
+# Language: Perl
+#
+# (c) Copyright 2005, Andrew@DeFaria.com, all rights reserved
+#
+################################################################################
+use strict;
+use warnings;
+use CQPerlExt;
+use File::Spec;
+
+our ($me, $SEPARATOR);
+
+my ($abs_path, $lib_path);
+
+BEGIN {
+ # Extract relative path and basename from script name.
+ $0 =~ /(.*)[\/\\](.*)/;
+
+ $abs_path = (!defined $1) ? "." : File::Spec->rel2abs ($1);
+ $me = (!defined $2) ? $0 : $2;
+ $me =~ s/\.pl$//;
+
+ # Remove .pl for Perl scripts that have that extension
+ $me =~ s/\.pl$//;
+
+ # Define the path SEPARATOR
+ $SEPARATOR = ($^O =~ /MSWin/) ? "\\" : "/";
+
+ # Setup paths
+ $lib_path = "$abs_path" . $SEPARATOR . ".." . $SEPARATOR . "lib";
+
+ # Add the appropriate path to our modules to @INC array.
+ unshift (@INC, "$abs_path");
+ unshift (@INC, "$lib_path");
+} # BEGIN
+
+use PQA;
+use Display;
+use Logger;
+use TimeUtils;
+
+my $from_db_connection_name = "2003.06.00";
+my $to_db_connection_name = "2005.02.00";
+my $id;
+
+sub Usage {
+ my $msg = shift;
+
+ display "ERROR: $msg\n" if defined $msg;
+
+ display "Usage: $me\t[-u] [-v] [-d] [-id <id>]
+ [-from <connection name>]
+ [-to <connection name>]
+
+Where:
+
+ -u: Display usage
+ -v: Turn on verbose mode
+ -d: Turn on debug mode
+ -id <id>: Process only the specified defect <id>
+ (Default: Process all defects)
+ -from <connection name>: Specify the from connection name
+ (Default: $from_db_connection_name)
+ -to <connection name>: Specify the to connection name
+ (Default: $to_db_connection_name)";
+ exit 1;
+} # Usage
+
+sub BurnIDsTil {
+ my $log = shift;
+ my $to = shift;
+ my $record_name = shift;
+ my $current_id = shift;
+ my $dest_id = shift;
+
+ my $entity;
+
+ while ($current_id < $dest_id) {
+ # Create a new entity and get it's ID until we reach $dest_id
+ $entity = $to->BuildEntity ($record_name);
+ $current_id = $entity->GetFieldValue ("id")->GetValue;
+
+ # Change $current_id to just the number portion
+ $current_id = substr $current_id, 4, 8;
+
+ # Burn the id if it is not equal to the $dest_id
+ $entity->Revert if $current_id < $dest_id;
+ } # while
+
+ return $entity;
+} # BurnIDsTil
+
+sub TransferState {
+ my $log = shift;
+ my $record_name = shift;
+ my $db = shift;
+ my $id = shift;
+ my $state = shift;
+
+ # There is no corresponding Submit state in Cont so we cannot
+ # transition it's state. For now we will leave it Assigned.
+ return if $state eq "Submit";
+
+ # State transition matrix: This hash defines a state to get to and
+ # an array of how to get there.
+ my %state_transition_matrix = (
+ "Assigned" => [
+ ],
+ "Resolved" => [
+ "Resolve"
+ ],
+ "Unassigned" => [
+ "Unassign"
+ ],
+ "Data_Pending" => [
+ "Data_Pending"
+ ],
+ "Verified" => [
+ "Resolve",
+ "Verify"
+ ],
+ "Awaiting_Cust_Verify" => [
+ "Resolve",
+ "Verify",
+ "VerifiedPendingCustVerify"
+ ],
+ "Closed" => [
+ "Resolve",
+ "Verify",
+ "Close"
+ ],
+ "Verified_Cust_Accepted" => [
+ "Resolve",
+ "Verify",
+ "VerifiedPendingCustVerify",
+ "CustomerVerified"
+ ],
+ );
+
+ # Not transition through the necessary states
+ my $current_state = $state;
+ my @actions = @{$state_transition_matrix {$current_state}};
+
+ debug "Transitioning $id to $current_state State";
+
+ foreach (@actions) {
+ debug "Applying action $_";
+
+ my $new_entity = $db->GetEntity ($record_name, $id);
+
+ $db->EditEntity ($new_entity, $_);
+
+ my $errmsg = $new_entity->Validate;
+
+ if ($errmsg ne "") {
+ verbose "";
+ $log->err ("\n$id\n$errmsg");
+ return;
+ } else {
+ # Post record to database
+ $new_entity->Commit;
+ } # if
+ } # foreach
+} # TransferState
+
+sub TransferDefects {
+ my $log = shift;
+ my $from = shift;
+ my $to = shift;
+ my $dbname = shift;
+ my $record_name = shift;
+ my $search_id = shift;
+ my @field_list = @_;
+
+ my $result;
+ my $new_id;
+
+ if (defined $search_id) {
+ $result = GetDefectRecord $log, $from, $record_name, $search_id;
+ } else {
+ $result = GetAllDefectRecords $log, $from, $record_name;
+ } # if
+
+ return if !$result;
+
+ my $old_bufffer_status = $|;
+ $| = 1; # Turn off buffering
+
+ my $nbr = 0;
+
+ # Seed $current_id - IOW what is the current ID in the destination
+ # database?
+ my $current_id;
+ if (!defined $search_id) {
+ my $entity = $to->BuildEntity ($record_name);
+ $current_id = $entity->GetFieldValue ("id")->GetValue;
+ } # if
+
+ # Now for each record returned by the query...
+ while ($result->MoveNext == $CQPerlExt::CQ_SUCCESS) {
+ # GetEntity by using $id
+ my $id = $result->GetColumnValue (1);
+ my $from_entity = $from->GetEntity ($record_name, $id);
+ my $title;
+ my @files_created;
+ my $history_filename = "history.txt";
+ my $to_entity;
+
+ if (!defined $search_id) {
+ # Check to see if $id > $current_id. If so then we can't
+ # proceed. If not then we need to burn up some IDs.
+ my $current_id_nbr = substr $current_id, 4, 8;
+ my $dest_id_nbr;
+
+ if ($id =~ /^Prod/) {
+ $dest_id_nbr = substr $id, 4, 8;
+ } else {
+ $dest_id_nbr = 20000 + (substr $id, 2, 8);
+ } # if
+
+ if ($current_id_nbr > $dest_id_nbr) {
+ error "Unable to sequence merge", 1;
+ } elsif ($current_id_nbr < $dest_id_nbr) {
+ $to_entity = BurnIDsTil $log, $to, $record_name, $current_id_nbr, $dest_id_nbr;
+ } # if
+ } else {
+ # Since $search_id is defined we're doing a single ID, in test
+ # mode, so generate a new $to_entity. IOW there is no sequencing
+ # going on...
+ $to_entity = $to->BuildEntity ($record_name);
+ } # if
+
+ $log->msg (++$nbr . ": Merging ID $id ", "nolf");
+
+ # Get the fields...
+ foreach (@field_list) {
+ my $name = $_;
+ my $value = $from_entity->GetFieldValue ($name)->GetValue;
+
+ # Here we handle the differences between records..
+ if ($dbname eq "TO") {
+ ## Field Translations
+
+ # TO: defect: AdvancedFeature -> Cont: defect: Advanced_Feature
+ if ($name eq "AdvancedFeature") {
+ $name = "Advanced_Feature";
+ AddToFieldChoiceList $to, $to_entity, $name, $name, $value;
+ } # if
+
+ # TO: defect: Fixed_In_Project -> Cont: defect: Fixed_In_Project
+ # but as a reference to Cont: Project
+ AddToFieldChoiceList $to, $to_entity, "Project", $name, $value if $name eq "Fixed_In_Project";
+
+ # TO: defect: Found_In_Project -> Cont: defect: Found_In_Project
+ # but as a reference to Cont: Project
+ AddToProject $log, $to, $value if $name eq "Found_In_Project";
+
+ # TO: defect: Fixed_In_SW_Version -> Cont: defect: Fixed_In_SW_Version
+ if ($name eq "Fixed_In_SW_Version") {
+ $value = "N/A" if $value eq "";
+ } # if
+
+ # TO: defect: History -> Cont: defect: <AttachmentBRCM>
+ # Transfer history item to an attachment
+ if ($name eq "History") {
+ TransferHistory ($from_entity, $to_entity, $history_filename);
+ } # if
+
+ ## Field renames
+
+ # TO: defect: GatingItem -> Cont: defect: Gating_Item_HW
+ $name = "Gating_Item_SW" if $name eq "GatingItem";
+
+ # TO: defect: HUT_Version -> Cont: defect: Board_Revision
+ if ($name eq "HUT_Version") {
+ $name = "Board_Revision";
+ $value = "Not Applicable" if $value eq "N/A";
+ AddToFieldChoiceList $to, $to_entity, $name, $name, $value;
+ } # if
+
+ # TO: defect: ReportedBy -> Cont: defect: Reported_By
+ if ($name eq "ReportedBy") {
+ $name = "Reported_By";
+ AddToFieldChoiceList $to, $to_entity, $name, $name, $value
+ } # if
+
+ # TO: defect: NoteBugReview -> Cont: defect: Bug_Review_Note
+ $name = "Bug_Review_Note" if $name eq "NoteBugReview";
+
+ # TO: defect: NoteBRCMOnly -> Cont: defect: Broadcom_Only_Note
+ $name = "Broadcom_Only_Note" if $name eq "NoteBRCMOnly";
+
+ # TO: defect: Open_Close_Status -> Cont: defect: Active_Deferred_Status
+ $name = "Active_Deferred_Status" if $name eq "Open_Close_Status";
+
+ # TO: defect: SQATestCase -> Cont: defect: PQATestCase
+ if ($name eq "SQATestCase") {
+ $name = "PQATestCase";
+ $value = "N/A" if $value eq "";
+ } # if
+
+ # TO: defect: Title_2 -> Cont: defect: Title
+ if ($name eq "Title_2") {
+ # There are some blank titles!
+ $value = "N/A" if $value eq "";
+ $title = $value;
+ $name = "Title";
+ } # if
+
+ ## Field deletes
+ next if $name eq "AttachmentsBRCM" or
+ $name eq "Project" or
+ $name eq "PendingHWSWReleases" or
+ $name eq "TestBlocking";
+ } elsif ($dbname eq "Prod") {
+ ## Field Translations
+
+ # Prod: defect: AdvancedFeature -> Cont: defect: Advanced_Feature
+ if ($name eq "AdvancedFeature") {
+ $name = "Advanced_Feature";
+ AddToFieldChoiceList $to, $to_entity, $name, $name, $value;
+ } # if
+
+ # Prod: defect: Fixed_In_Project -> Cont: defect: Project
+ # but as a reference to Cont: Project
+ AddToFieldChoiceList $to, $to_entity, "Project", $name, $value if $name eq "Fixed_In_Project";
+
+ # Prod: defect: Fixed_In_SW_Version -> Cont: defect: Fixed_In_SW_Version
+ if ($name eq "Fixed_In_SW_Version") {
+ $value = "N/A" if $value eq "";
+ } # if
+
+ # Prod: defect: History -> Cont: defect: <AttachmentBRCM>
+ # Transfer history item to an attachment
+ if ($name eq "History") {
+ TransferHistory ($from_entity, $to_entity, $history_filename);
+ } # if
+
+ # Prod: defect: Category -> Cont: defect: Category
+ if ($name eq "Category") {
+ # There is no "Hardware" anymore so translating them to "Hardware - Board"
+ if ($value eq "Hardware") {
+ $value = "Hardware - Board";
+ } # if
+ } # if
+
+ # Prod: defect: GatingItem -> Cont: defect: Gating_Item_HW
+ $name = "Gating_Item_SW" if $name eq "GatingItem";
+
+ # Prod: defect: HUT_Version -> Cont: defect: Board_Revision
+ if ($name eq "HUT_Version") {
+ $name = "Board_Revision";
+ $value = $value ne "" ? $value : "Not Applicable";
+ $value = "Not Applicable" if $value eq "N/A";
+ if ($value eq "BCM95704CA40 v1.0 revA0 ") {
+ # Trailing blank is wrong! - Removing it
+ $value = "BCM95704CA40 v1.0 revA0";
+ } # if
+ AddToFieldChoiceList $to, $to_entity, $name, $name, $value;
+ } # if
+
+ # Prod: defect: Issue_Classification -> Cont: defect: Issue_Classification
+ # There are no: Hardware in the new Cont database so we'll map it to
+ # "Requirement"
+ if ($name eq "Issue_Classification") {
+ $value = "Requirement" if $value eq "Hardware";
+ } # if
+
+ # Prod: defect: NoteBugReview -> Cont: defect: Bug_Review_Note
+ $name = "Bug_Review_Note" if $name eq "NoteBugReview";
+
+ # Prod: defect: NoteBRCMOnly -> Cont: defect: Broadcom_Only_Note
+ $name = "Broadcom_Only_Note" if $name eq "NoteBRCMOnly";
+
+ # Prod: defect: Open_Close_Status -> Cont: defect: Active_Deferred_Status
+ $name = "Active_Deferred_Status" if $name eq "Open_Close_Status";
+
+ # Prod: defect: Project -> Cont: defect: Found_In_Project
+ if ($name eq "Project") {
+ AddToProject $log, $to, $value;
+ $name = "Found_In_Project";
+ } # if
+
+ # Prod: defect: ReportedBy -> Cont: defect: Reported_By
+ if ($name eq "ReportedBy") {
+ $name = "Reported_By";
+ AddToFieldChoiceList $to, $to_entity, $name, $name, $value
+ } # if
+
+ # Prod: defect: Resolution -> Cont: defect: Resolution
+ if ($name eq "Resolution") {
+ # There is no "HW Fix" anymore so translating them to "Hw Fix - Board"
+ if ($value eq "HW Fix") {
+ $value = "HW Fix - Board";
+ } elsif ($value eq "MAC Core") {
+ $value = "HW Fix - MAC Core";
+ }# if
+ } # if
+
+ # Prod: defect: Software_Version -> Cont: defect: Software_Version
+ if ($name eq "Software_Version") {
+ $value = "N/A" if $value eq "" or $value eq " ";
+ } # if
+
+ # Prod: defect: Title -> Cont: defect: Title
+ if ($name eq "Title") {
+ $value = $value ne "" ? $value : "<N/A>";
+ $title = $value;
+ } # if
+
+ # Prod: defect: SQATestcase -> Cont: defect: PQATestCase
+ if ($name eq "SQATestCase") {
+ $name = "PQATestCase";
+ $value = "N/A" if $value eq "";
+ } # if
+
+ # Prod: defect: Title_2 -> Cont: defect: Title
+ $name = "Title" if $name eq "Title_2";
+
+ ## Field deletes
+ next if $name eq "AttachmentBRCM" or
+ $name eq "Project_Name" or
+ $name eq "PendingHWSWReleases" or
+ $name eq "TestBlocking";
+ } # if
+
+ # Check field for non US ASCII characters and fix them
+ $value = CheckField $dbname, $record_name, $id, $name, $value;
+
+ ## Handle dynamic choice lists
+
+ # While the field name is DeferredToProject, it's corresponding
+ # Dynamic list name is actually Project
+ AddToFieldChoiceList $to, $to_entity, "Project", $name, $value if $name eq "DeferredToProject";
+
+ # While the field name is CommittedToProject, it's corresponding
+ # Dynamic list name is actually Project
+ AddToFieldChoiceList $to, $to_entity, "Project", $name, $value if $name eq "CommittedToProject";
+
+ if ($name eq "HUT") {
+ $value = "BRCM Copper (do not use)" if $value eq "Broadcom Copper";
+ $value = "BRCM Fiber (do not use)" if $value eq "Broadcom Fiber Optic";
+ } # if
+
+ AddToFieldChoiceList $to, $to_entity, $name, $name, $value if $name eq "HUT";
+
+ if ($name eq "HUT_Revision") {
+ $value = "N/A"
+ if $value eq "" or
+ $value eq "\?" or
+ $value eq "\?\?\?" or
+ $value eq "A0-A4,B0-B1" or
+ $value eq "All" or
+ $value eq "all revisions" or
+ $value eq "n" or
+ $value eq "n/" or
+ $value eq "n\a" or
+ $value eq "na" or
+ $value eq "n/a ";
+ $value = "A0" if $value eq "BCM5752 A0";
+ $value = "A1" if $value eq "BCM5752 A1 10x10 package";
+ $value = "A2" if $value eq "A2 (A3 Silent)";
+ $value = "A3" if $value eq "A3 silent (A2)";
+ $value = "B1" if $value eq "B1/A1";
+ AddToFieldChoiceList $to, $to_entity, $name, $name, $value;
+ } # if
+
+ if ($name eq "Service_Pack") {
+ $value = "Not Applicable"
+ if $value eq "" or
+ $value eq "\?" or
+ $value eq "na" or
+ $value eq "N/A" or
+ $value eq "none" or
+ $value eq "Notice that QA applies to bootcode + Win + Linux d";
+ $value = "SP3" if $value eq "SP3 ";
+ $value = "SP4" if $value eq "SP4 ";
+ $value = "Suse 9" if $value eq "Suse 9 ";
+ } # if
+
+ # While the field name is Service_Pack, it's corresponding
+ # Dynamic list name is actually OS_Service_Pack!
+ AddToFieldChoiceList $to, $to_entity, "OS_Service_Pack", $name, $value if $name eq "Service_Pack";
+
+ AddToFieldChoiceList $to, $to_entity, $name, $name, $value if $name eq "Software";
+ AddToFieldChoiceList $to, $to_entity, $name, $name, $value if $name eq "Visibility";
+ if ($name eq "OS") {
+ $value = "Novell 6 Pack Beta 3" if $value eq "Novell 6 Pack Beta 3 ";
+ AddToFieldChoiceList $to, $to_entity, $name, $name, $value if $name eq "OS";
+ } # if
+
+ # Set the field's value
+ $to_entity->SetFieldValue ($name, $value);
+ } # for
+
+ ## New fields
+
+ # Found_On_Gold: Default to "No"
+ $to_entity->SetFieldValue ("Found_On_Gold", "No");
+
+ # Gating_Item_HW: Default to "No"
+ $to_entity->SetFieldValue ("Gating_Item_HW", "No");
+
+ # Newly_Introduce: Default to "No"
+ $to_entity->SetFieldValue ("Newly_Introduce", "No");
+
+ # Root_Caused: Default to "No"
+ $to_entity->SetFieldValue ("Root_Caused", "No");
+
+ # Throw old ID from Prod or TO into old_id. This can then serve
+ # As a cross reference
+ $to_entity->SetFieldValue ("old_id", $id);
+
+ # Need to handle attachments differently...
+ @files_created = TransferAttachments $log, $from_entity, $to_entity;
+
+ # Call the Validate method
+ my $errmsg = $to_entity->Validate;
+
+ if ($errmsg ne "") {
+ verbose "";
+ $log->err ("\n$id\n$errmsg");
+ } else {
+ # Post record to database
+ $to_entity->Commit;
+ $new_id = $to_entity->GetFieldValue ("id")->GetValue;
+ $log->msg ("-> $new_id");
+ } # if
+
+ # Clean up files created by TransferAttachments - if any
+ foreach (@files_created) {
+ unlink $_;
+ } # foreach
+
+ # Clean up files created by TransferHistory
+ unlink $history_filename;
+
+ # Transfer State: The entity we just created is now in the
+ # Assigned state. But that's not the same as the state of the
+ # original entity. The following code attempts to fix this.
+ my $old_state = $from_entity->GetFieldValue ("State")->GetValue;
+
+ TransferState $log, $record_name, $to, $new_id, $old_state;
+ } # while
+
+ $| = $old_bufffer_status; # Restore buffering
+
+ return $new_id;
+} # TransferDefects
+
+while ($ARGV [0]) {
+ if ($ARGV [0] eq "-v") {
+ Display::set_verbose;
+ Logger::set_verbose;
+ } elsif ($ARGV [0] eq "-d") {
+ set_debug;
+ } elsif ($ARGV [0] eq "-id") {
+ shift;
+ if (!$ARGV [0]) {
+ Usage "Must specify ID after -id";
+ } else {
+ $id = $ARGV [0];
+ } # if
+ } elsif ($ARGV [0] eq "-from") {
+ shift;
+ if (!$ARGV [0]) {
+ Usage "Must specify <connection name> after -from";
+ } else {
+ $from_db_connection_name = $ARGV [0];
+ } # if
+ } elsif ($ARGV [0] eq "-to") {
+ shift;
+ if (!$ARGV [0]) {
+ Usage "Must specify <connection name> after -to";
+ } else {
+ $to_db_connection_name = $ARGV [0];
+ } # if
+ } elsif ($ARGV [0] eq "-u") {
+ Usage;
+ } else {
+ Usage "Unknown argument found: " . $ARGV [0];
+ } # if
+
+ shift (@ARGV);
+} # while
+
+my $log = Logger->new (path => ".");
+
+my $process_start_time = time;
+my $start_time;
+
+$log->msg ("Starting Cont session");
+my $controller = StartSession "Cont", $to_db_connection_name;
+
+my $do_prod = 1;
+my $do_teton = 1;
+my $current_id;
+my $record_name = "defect";
+
+if ($do_prod) {
+ $log->msg ("Starting Prod session");
+ my $prod = StartSession ("Prod", $from_db_connection_name);
+
+ $log->msg ("Transferring Prod:defect -> Cont:defect");
+ $start_time = time;
+ $current_id = TransferDefects $log, $prod, $controller, "Prod", $record_name, $id, @old_Prod_defect_fields;
+ $log->msg ("Completed transfer of Prod:defect records");
+ display_duration $start_time, $log;
+
+ $log->msg ("Ending Prod session");
+ EndSession $prod;
+} # if
+
+if ($do_teton) {
+ $log->msg ("Starting TO session");
+ my $teton = StartSession "TO", $from_db_connection_name;
+
+ $log->msg ("Transferring TO:defect -> Cont:defect");
+ $start_time = time;
+
+ if (!defined $id) {
+ my $current_id_nbr = substr $current_id, 4, 8;
+ # Start numbering TO at 20000
+ BurnIDsTil $log, $controller, $record_name, $current_id_nbr, "20000";
+ } # if
+ TransferDefects $log, $teton, $controller, "TO", $record_name, $id, @old_TO_defect_fields;
+ $log->msg ("Completed transfer of TO:defect records");
+ display_duration $start_time, $log;
+
+ $log->msg ("Ending TO session");
+ EndSession $teton;
+} # if
+
+$log->msg ("Ending Cont session");
+EndSession $controller;
+
+verbose "Total processing time:";
+display_duration $process_start_time, $log;
--- /dev/null
+#!/usr/local/bin/perl5.8.4
+################################################################################
+#
+# File: cvsims,v
+# Revision: 1.1.1.1
+# Author: Andrew@DeFaria.com
+# Description: This script will read CVS commit information searching for Issue
+# IDs and formulate a "change set" including the files committed
+# and update IMS.
+# Created: Fri Dec 9 15:10:56 PST 2005
+# Modified: 2007/05/17 07:45:48
+# Language: perl
+#
+# (c) Copyright 2005, Andrew@DeFaria.com, all rights reserved
+#
+################################################################################
+use strict;
+use warnings;
+use File::Spec;
+
+my $me;
+my $version = "1.0";
+
+BEGIN {
+ # Set $lib_path
+ my $lib_path = $^O =~ /MSWin/ ? "\\\\brcm-irv\\dfs\\projects\\ccase\\SCM\\lib"
+ : "/projects/ccase/SCM/lib";
+
+ # Extract relative path and basename from script name.
+ $0 =~ /(.*)[\/\\](.*)/;
+
+ my $abs_path = (!defined $1) ? "." : File::Spec->rel2abs ($1);
+ $me = (!defined $2) ? $0 : $2;
+ $me =~ s/\.pl$//;
+
+ # Add the appropriate path to our modules to @INC array.
+ unshift @INC, $ENV {SITE_PERL_LIBPATH} if defined $ENV {SITE_PERL_LIBPATH};
+ unshift @INC, "$lib_path";
+ unshift @INC, "$abs_path";
+} # BEGIN
+
+use IMS;
+use Display;
+
+sub Usage {
+ my $msg = shift;
+
+ display "ERROR: $msg\n" if defined $msg;
+
+ display "Usage: $me\t[-u] [-v] [-d] [-passthru]
+\t\t[{-pre -logfile <filename>} |
+\t\t {-post -repository <repository> -path <path>
+\t\t <file> <rev> {<file> <rev>...}}]
+
+Where:
+
+ -u: Display usage
+ -v: Turn on verbose mode
+ -d: Turn on debug mode
+ -passthru: Passthru stdin to stdout
+
+Pre options:
+ -pre: Perform pre commit checking.
+ -logfile Path to logfile containing commit message
+
+Post options:
+ -post: Perform post commit updating
+ -repository: Repository (path portion of \$CVSROOT)
+ -path: Path relative to repository
+ <file> <rev>: Files and revisions commited (Format: \"file rev file rev ...\")
+";
+ exit 1;
+} # Usage
+
+sub UpdateIMS {
+ my $issueid = shift;
+ my $repository = shift;
+ my $path = shift;
+ my %filerevs = @_;
+
+ my $change_set;
+
+ foreach (sort (keys (%filerevs))) {
+ $change_set .= "${filerevs {$_}}\t$repository/$path/$_\n";
+ } # foreach
+
+ my $error = AddToChangeSet ($issueid, $change_set);
+
+ return $error;
+} # UpdateIMS
+
+sub ParseInput {
+ my @input = @_;
+
+ my $sentinal = "csp: ";
+ my %issue_ids;
+ my @issue_ids;
+ # Issue id information in the input must have the following format:
+ #
+ # $sentinal <n>, {n}
+ foreach my $line (@input) {
+ if ($line =~ /^$sentinal/i) {
+ # Remove $sentinal
+ $line = substr $line, length ($sentinal);
+ # Remove and commas
+ $line =~ tr /,/ /;
+ @issue_ids = split /\s+/, $line;
+ last;
+ } # if
+ } # foreach
+
+ # Eliminate duplicates on return
+ return grep (!$issue_ids {$_}++, @issue_ids);
+} # ParseInput
+
+sub ReadFile {
+ my $file = shift;
+ my $passthru = shift;
+
+ my @lines = <$file>;
+
+ my @cleansed_lines;
+
+ foreach (@lines) {
+ print $_ if $passthru;
+ chomp;
+ chop if /\r/;
+ push @cleansed_lines, $_ if !/^#/; # Discard comment lines
+ } # foreach
+
+ return @cleansed_lines;
+} # ReadFile
+
+my $optkind;
+my $repository;
+my $path;
+my $passthru = 0;
+my $logfile;
+my %filerevs;
+
+while ($ARGV [0]) {
+ if ($ARGV [0] eq "-v") {
+ Display::set_verbose;
+ } elsif ($ARGV [0] eq "-d") {
+ set_debug;
+ } elsif ($ARGV [0] eq "-passthru") {
+ $passthru = 1;
+ } elsif ($ARGV [0] eq "-repository") {
+ shift @ARGV;
+ if (!$ARGV [0]) {
+ Usage "Must specify repository after -repository";
+ } else {
+ $repository = $ARGV [0];
+ } # if
+ } elsif ($ARGV [0] eq "-path") {
+ shift @ARGV;
+ if (!$ARGV [0]) {
+ Usage "Must specify path after -path";
+ } else {
+ $path = $ARGV [0];
+ } # if
+ } elsif ($ARGV [0] eq "-pre") {
+ $optkind = "pre";
+ } elsif ($ARGV [0] eq "-logfile") {
+ shift @ARGV;
+ if (!$ARGV [0]) {
+ Usage "Must specify log filename after -logfile";
+ } else {
+ $logfile = $ARGV [0];
+ } # if
+ } elsif ($ARGV [0] eq "-post") {
+ $optkind = "post";
+ } elsif ($ARGV [0] eq "-u") {
+ Usage;
+ } else {
+ %filerevs = @ARGV;
+ last;
+ } # if
+
+ shift (@ARGV);
+} # while
+
+Usage "Must specify -pre or -post" if !defined $optkind;
+
+if ($optkind eq "pre") {
+ Usage "No logfile to parse" if !defined $logfile;
+} elsif ($optkind eq "post") {
+ Usage "No files committed" if !%filerevs;
+} # if
+
+my @issue_ids;
+
+if ($optkind eq "pre") {
+ verbose "$me v$version: Checking for Issue ID(s)...";
+ open LOGFILE, $logfile
+ or error "Unable to open logfile $logfile - $!", 4;
+
+ @issue_ids = ParseInput ReadFile (*LOGFILE);
+
+ close LOGFILE;
+} else {
+ # Special case here. Seems cvs will call this script through loginfo
+ # even though directories are not versioned in cvs. If so then
+ # %filerevs will contain "- New directory" and "NONE". In this case
+ # we simply exit 0.
+ if (defined $filerevs {"- New directory"}) {
+ exit 0;
+ } # if
+
+ verbose "$me v$version: Updating Issue ID(s)...";
+ @issue_ids = ParseInput ReadFile (*STDIN, $passthru);
+} # if
+
+if (scalar (@issue_ids) eq 0) {
+ error "No issue ID(s) found", 1;
+} # if
+
+verbose "Verifying Issue IDs";
+
+foreach (@issue_ids) {
+ my %issue_info = GetIssue $_;
+
+ if (%issue_info) {
+ verbose "Issue $_ exists in IMS";
+ } else {
+ error "Issue ID $_ does not exist in IMS", 2 if !%issue_info;
+ } # if
+} # foreach
+
+if ($optkind eq "post") {
+ foreach my $issue_id (@issue_ids) {
+ verbose "Updating Issue ID ${issue_id}'s Change Set";
+
+ my $error = UpdateIMS $issue_id, $repository, $path, %filerevs;
+
+ if ($error ne "") {
+ error $error, 3;
+ } else {
+ verbose "Issue ID ${issue_id}'s Change Set updated";
+ } # if
+ } # foreach
+} # if
+
+exit 0;
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: ecrc: ECR client
+# Description: This script is a test client for ecrd.
+# Author: Andrew@DeFaria.com
+# Created: Tue Feb 15 11:01:24 PST 2005
+# Modified:
+# Language: Perl
+#
+# (c) Copyright 2005, LynuxWorks, all rights reserved.
+#
+################################################################################
+use strict;
+use warnings;
+use File::Spec;
+
+my ($me, $abs_path, $lib_path, $bin_path, $log_path);
+
+BEGIN {
+ # Extract relative path and basename from script name.
+ $0 =~ /(.*)[\/\\](.*)/;
+
+ $abs_path = (!defined $1) ? "." : File::Spec->rel2abs ($1);
+ $me = (!defined $2) ? $0 : $2;
+ $me =~ s/\.pl$//;
+
+ # Setup paths
+ $bin_path = "$abs_path";
+ $lib_path = "$abs_path/../lib";
+ $log_path = "$abs_path/../log";
+
+ # Add the appropriate path to our modules to @INC array.
+ unshift (@INC, "$lib_path");
+} # BEGIN
+
+use ecrc;
+
+# Global variables
+my $servername = (!defined $ENV {ECRDSERVER}) ? "lynx12" : $ENV {ECRDSERVER};
+my $port = (!defined $ENV {ECRDPORT}) ? 1500 : $ENV {ECRDPORT};
+my $ecr = "";
+my @query_fields = ();
+my $verbose;
+my $debug;
+my $key;
+my $value;
+my %fields;
+my @ecrs;
+
+sub Usage {
+ my $msg = shift;
+
+ print "ERROR: $msg\n\n" if defined $msg;
+
+ print "Usage: ecrc [-u] [-v] [-d] [ -s <server> ] [ -p <port> ] ";
+ print "ECR [ fieldname... ]\n";
+ print "\nWhere:\n\n";
+ print "\t-u:\t\tDisplay usage\n";
+ print "\t-v:\t\tTurn on verbose mode (Default off)\n";
+ print "\t-d:\t\tTurn on debug mode (Default off)\n";
+ print "\t-s:\t\tUse server named servername (Default lynx12)\n";
+ print "\t-s:\t\tUse port (Default 1500)\n";
+ print "\tECR:\t\tECR number to obtain info about\n";
+ print "\tfieldname:\tECR field names to retrieve info about (Default all)\n";
+
+ exit 1;
+} # Usage
+
+sub GetParms {
+ while ($ARGV [0]) {
+ if ($ARGV [0] eq "-v") {
+ $verbose = 1;
+ ecrc::set_verbose;
+ } elsif ($ARGV [0] eq "-d") {
+ $debug = 1;
+ ecrc::set_debug;
+ } elsif ($ARGV [0] eq "-u") {
+ Usage;
+ } elsif ($ARGV [0] eq "-p") {
+ shift @ARGV;
+ Usage "Port not specified" if !$ARGV [0];
+ $port = shift @ARGV;
+ } elsif ($ARGV [0] eq "-s") {
+ shift @ARGV;
+ Usage "Server name not specified" if !$ARGV [0];
+ $servername = shift @ARGV;
+ } else {
+ $ecr = shift (@ARGV);
+ last;
+ } # if
+ shift @ARGV;
+ } # while
+
+ @query_fields = @ARGV;
+
+ # Downshift any query_fields
+ my $i = 0;
+
+ foreach (@query_fields) {
+ $query_fields [$i++] = lc $_;
+ } # foreach
+} # GetParms
+
+# Main code
+GetParms;
+
+die "Unable to connect to $servername:$port\n" if !ecrc::Connect ($servername, $port);
+
+if ($ecr) {
+ if ($ecr eq "\*") {
+ @ecrs = ecrc::GetECRRecord $ecr;
+
+ foreach (@ecrs) {
+ print "$_\n";
+ } # foreach
+
+ exit;
+ } # if
+
+ %fields = ecrc::GetECRRecord ($ecr);
+
+ if (!%fields) {
+ print "ECR $ecr was not found\n";
+ } else {
+ if (@query_fields) {
+ foreach (@query_fields) {
+ if (@query_fields > 1) {
+ if (defined $fields{$_}) {
+ print "$_: $fields{$_}\n";
+ } else {
+ print "$_: <FIELD NOT FOUND>\n";
+ } # if
+ } else {
+ if (defined $fields{$_}) {
+ print "$fields{$_}\n";
+ } else {
+ print "$_: <FIELD NOT FOUND>\n";
+ } # if
+ } # if
+ } # foreach
+ } else {
+ while (($key, $value) = each (%fields)) {
+ print "$key: $value\n";
+ } # while
+ } # if
+ } # if
+} else {
+ print "Enter ECR:";
+
+ while (my $command = <STDIN>) {
+ chomp $command;
+ last if $command =~ m/exit|quit/i;
+
+ $ecr = $command;
+
+ if ($ecr eq "\*") {
+ my @ecrs = ecrc::GetECRRecord $ecr;
+
+ foreach (@ecrs) {
+ print "$_\n";
+ } # foreach
+ } else {
+ %fields = ecrc::GetECRRecord $ecr;
+
+ if (!%fields) {
+ print "ECR $ecr was not found\n";
+ } else {
+ while (($key, $value) = each (%fields)) {
+ print "$key: $value\n";
+ } # while
+ } # if
+ } # if
+
+ print "Enter ECR:";
+ } # while
+} # if
--- /dev/null
+<?php
+////////////////////////////////////////////////////////////////////////////////
+//
+// File: ecrc.php: ECR Daemon Client Library
+// Description: Php Module interface to ecrd (ECR Daemon).
+// Author: Andrew@DeFaria.com
+// Created: Tue Feb 15 09:40:57 PST 2005
+// Modified:
+// Language: Php
+//
+// (c) Copyright 2005, LynuxWorks, all rights reserved.
+//
+////////////////////////////////////////////////////////////////////////////////
+require_once "Net/Socket.php";
+
+define ("SERVER", "lynx12");
+define ("PORT", 1500);
+
+$ecrserver;
+$verbose = $_REQUEST [verbose];
+$debug = $_REQUEST [debug];
+
+function verbose ($msg) {
+ global $verbose;
+
+ if ($verbose == 1) {
+ print "$msg<br>";
+ } // if
+} // verbose
+
+function debug ($msg) {
+ global $debug;
+
+ if ($debug == 1) {
+ print "DEBUG: $msg<br>";
+ } // if
+} // debug
+
+function Connect ($host, $port = 1500) {
+ global $ecrserver;
+
+ debug ("Connect ($host, $port)");
+
+ $ecrserver = ConnectToServer ($host, $port);
+
+ if (is_object ($ecrserver)) {
+ verbose ("Connected to $host");
+ SendServerAck ($ecrserver);
+ } // if
+
+ return $ecrserver;
+} // Connect
+
+function Disconnect () {
+ global $ecrserver;
+ global $command;
+
+ $msg;
+
+ if ($ecrserver) {
+ if ($command == "shutdown") {
+ $msg = "Disconnected from server - shutdown server";
+ } else {
+ $command = "quit";
+ $msg = "Disconnected from server";
+ } // if
+ SendServerCmd ($ecrserver, $command);
+ GetServerAck ($ecrserver);
+ verbose ($msg);
+ $ecrserver->disconnect ();
+ } // if
+} // Disconnect
+
+function GetECRRecord ($ecr) {
+ global $ecrserver;
+
+ $fields;
+
+ debug ("ENTER GetECRRecord ($ecr)");
+ if (!$ecrserver) {
+ verbose ("Not connected to server yet!");
+ verbose ("Attempting connection to $default_server...");
+ if (!Connect (SERVER)) {
+ print "Unable to connect to server ". SERVER . "<br>";
+ exit (1);
+ } // if
+ } // if
+
+ SendServerCmd ($ecrserver, $ecr);
+ GetServerAck ($ecrserver);
+
+ if ($ecr == "*") {
+ verbose ("Getting all ECRs");
+ $fields = GetServerList ($ecrserver);
+ } else {
+ verbose ("Getting specific ECR $ecr");
+ $fields = GetServerResponse ($ecrserver);
+ } // if
+
+ SendServerAck ($ecrserver);
+
+ return $fields;
+} // GetECRRecord
+
+function Shutdown () {
+ global $command;
+
+ verbose ("Sending disconnect command to server");
+ $command = "quit";
+ Disconnect ();
+} // Shutdown
+
+function ConnectToServer ($host, $port = 1500) {
+ $socket = new Net_Socket ();
+
+ debug ("Socket created... Attempting to connect to $host:$port");
+ // create a tcp connection to the specified host and port
+ if (@$socket->connect ($host, $port) == 1) {
+ verbose ("Socket $socket connected");
+ } else {
+ print "Unable to connect to server $host:$port!<br>";
+ exit (1);
+ } // if
+
+ return $socket;
+} // ConnectToServer
+
+function SendServerAck ($server) {
+ $server->write ("ACK" . "\n");
+} // SendServerAck
+
+function GetServerAck ($server) {
+ while ($srvresp = $server->readLine ()) {
+ if ($srvresp == "ACK") {
+ return;
+ } // if
+ verbose ("Received $srvresp from server - expected ACK");
+ } // while
+} // GetServerAck
+
+function GetServerList ($server) {
+ $ecrs = array ();
+
+ while ($srvresp = $server->readLine ()) {
+ if ($srvresp == "ACK") {
+ break;
+ } // if
+
+ if (preg_match ("/ECR.*was not found/", $srvresp)) {
+ return;
+ } else {
+ array_push ($ecrs, $srvresp);
+ } // if
+ } // while
+
+ return $ecrs;
+} # GetServerList
+
+function GetServerResponse ($server) {
+ $fields;
+
+ while ($srvresp = $server->readLine ()) {
+ if ($srvresp == "ACK") {
+ break;
+ } // if
+
+ if (preg_match ("/ECR.*was not found/", $srvresp)) {
+ return;
+ } else {
+ preg_match ("/(^\w+):\s+(.*)/s", $srvresp, $matches);
+ $value = str_replace ("\\n", "\n", $matches [2]);
+ $fields {$matches [1]} = $value;
+ } // if
+ } // while
+
+ return $fields;
+} // GetServerResponse
+
+function SendServerCmd ($server, $command) {
+ $server->write ($command . "\n");
+} // SendServerCmd
+?>
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: ecrd: ECR Daemon
+# Description: This script implements a daemon that handles requests for
+# queries about information on ECRs contained in the Quintus
+# database. In addition to lessoning the amount of time it takes
+# for database opens, access to Quintus data is only available
+# on certain machines. Additionally, for Perl to access this
+# Informix database the Informix version of DBD would need to be
+# locally installed. By calling this daemon instead clients need
+# not have to install Informix and then code all the necessary
+# code to access Quintus data as well as have to understand the
+# structure of the database. Instead clients need only say "Give
+# me what you got on ECR #<whatever>".
+# Author: Andrew@DeFaria.com
+# Created: Tue Feb 15 09:54:59 PST 2005
+# Modified:
+# Language: Perl
+#
+# (c) Copyright 2005, LynuxWorks, all rights reserved.
+#
+################################################################################
+use strict;
+use warnings;
+
+use IO::Socket;
+use Net::hostent;
+use POSIX qw(setsid);
+use DBI;
+
+my $ecrdb = "lynxmigr1";
+my $port = (!defined $ENV {ECRDPORT}) ? 1500 : $ENV {ECRDPORT};
+
+# Global variables
+my $DB;
+my $ecrserver;
+my $ecrclient;
+my $sth;
+my $statement;
+
+# Options
+my $verbose;
+my $debug;
+my $daemon_mode;
+my $quiet_mode;
+my $multithreaded;
+my $timeout = 10;
+
+# ECR translations. Note the Quintus database stores certain choice lists as
+# enumerations. They I guess they are configurable. The right thing to do
+# would be to figure out how to look up the definition given the number. But
+# we are gonna cheat here and hard code a few important enumerations.
+my @defstatus = (
+ "Open",
+ "Closed",
+ "Fixed",
+ "Not a bug",
+ "Obsolete",
+ "Defered",
+ "Duplicate"
+);
+my @state = (
+ "Reported",
+ "Assigned",
+ "Selected",
+ "Resolved",
+ "Integrated",
+ "Retired",
+ "Reviewed",
+ "Pending Review"
+);
+my @priority = (
+ "Low",
+ "Medium",
+ "High",
+ "Critical"
+);
+my @severity = (
+ "Low",
+ "Medium",
+ "High",
+ "Critical"
+);
+
+# Pid
+my $pid = $$;
+
+my $me = `basename $0`;
+chomp $me;
+my $ecrdversion = "1.3";
+
+my @all_fields = (
+ "productdefect", # integer
+ "componentdefect", # integer
+ "defectdefectdup", # integer
+ "workgroupdefect", # integer
+ "reporterdefect", # integer
+ "resolverdefect", # integer
+ "confirmerdefect", # integer
+ "buildversdefect", # integer
+ "rpt_versdefect", # integer
+ "res_versdefect", # integer
+ "conf_versdefect", # integer
+ "state", # integer
+ "resolverstatus", # integer
+ "confirmerstatus", # integer
+ "escstatus", # integer
+ "owner", # integer
+ "severity", # integer
+ "priority", # integer
+ "summary", # varchar(80,0)
+ "datereported", # datetime year to second
+ "dateresolved", # datetime year to second
+# "description", # text
+# Note: Some descriptions fields are huge containing things like
+# uuencoded tar files! They are so huge that they cause this server
+# to fail (not sure why - it shouldn't but it does. So this hack
+# returns only the first 50K of description to avoid that problem.
+ "description [1,50000]", # text
+ "cclist", # varchar(80,0)
+ "dateconfirmed", # datetime year to second
+ "datemodified", # datetime year to second
+ "fix_by_date", # date
+ "fix_by_version", # integer
+ "history", # text
+ "likelihood", # integer
+ "estfixtime", # datetime year to second
+ "actfixtime", # datetime year to second
+ "resolution", # text
+ "businessimpact", # integer
+ "origin", # integer
+ "docimpact", # integer
+ "report_platform", # integer
+ "resolve_platform", # integer
+ "confirm_platform", # integer
+ "test_file", # varchar(64,0)
+ "visibility", # integer
+ "misc", # varchar(80,0)
+ "defecttype", # integer
+ "defstatus", # integer
+ "customertext", # text
+ "modifiedby", # varchar(20,0)
+ "classification", # integer
+ "datefixed" # datetime year to second
+);
+
+# Forwards
+sub CloseDB;
+sub GetRequest;
+
+sub timestamp {
+ my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = localtime(time);
+
+ $mday = "0$mday" if $mday < 10;
+ $mon = "0$mon" if $mon < 10;
+ $hour = "0$hour" if $hour < 10;
+ $min = "0$min" if $min < 10;
+ $year += 1900;
+
+ return "$mon/$mday/$year $hour:$min";
+} # timestamp
+
+sub log_message {
+ print "[$pid] " . timestamp . " @_\n" if defined $verbose;
+} # log_message
+
+sub log_error {
+ print STDERR "[$pid] " . timestamp . " ERROR: @_\n"
+} # log_error
+
+sub log_warning {
+ print STDERR "[$pid] " . timestamp . " WARNING: @_\n"
+} # log_error
+
+sub debug {
+ print "[$pid] " . timestamp . " @_\n" if defined $debug;
+} # debug
+
+sub verbose {
+ print "[$pid] " . timestamp . " @_\n" if !defined $quiet_mode;
+} # verbose
+
+sub DBError {
+ my $msg = shift;
+ my $statement = shift;
+
+ if (!defined $DB) {
+ print "Catostrophic error: DB undefined!\n";
+ exit 1;
+ } # if
+
+ print $msg . "\nError #" . $DB->err . " " . $DB->errstr . "\n";
+ print "SQL Statement: $statement\n" if defined $statement;
+
+ exit $DB->err;
+} # DBError
+
+sub timeout {
+ debug "After $timeout seconds of inactivity client timed out";
+
+ my $hostinfo = gethostbyaddr ($ecrclient->peeraddr);
+ my $host = $hostinfo->name || $ecrclient->peerhost;
+ debug "Closing connection to $host";
+
+ # Close client's connection
+ close $ecrclient;
+
+ # Set up signal handlers again
+ $SIG{ALRM} = \&timeout;
+ $SIG{INT} = $SIG{QUIT} = 23234
+\&interrupt;
+ GetRequest;
+} # timeout
+
+sub interrupt {
+ log_warning "Interrupted - closing down...";
+ close $ecrserver;
+ verbose "Connection closed";
+ CloseDB;
+
+ exit;
+} # interrupt
+
+sub GetClientAck {
+ my $client = shift;
+ my $clientresp;
+
+ debug "ENTER: GetClientAck";
+ alarm $timeout;
+ while (defined $client and defined ($clientresp = <$client>)) {
+ chomp $clientresp;
+ chop $clientresp if $clientresp =~ /\r/;
+ if ($clientresp eq "ACK") {
+ return
+ } # if
+ log_warning "Received $clientresp from client - expected ACK";
+ } # while
+ debug "EXIT: GetClientAck";
+} # GetClientAck
+
+sub GetClientCmd {
+ my $client = shift;
+ my $clientresp;
+
+ alarm $timeout;
+ while (defined $client and defined ($clientresp = <$client>)) {
+ chomp $clientresp;
+ return $clientresp;
+ } # while
+} # GetClientResponse
+
+sub SendClientAck {
+ my $client = shift;
+
+ debug "ENTER: SendClientAck";
+ print $client "ACK\n";
+ debug "EXIT: SendClientAck";
+} # SendClientAck
+
+sub SendClientResponse {
+ my $client = shift;
+ my $response = shift;
+
+ print $client "$response\n";
+} # SendClientResponse
+
+sub EnterDaemonMode {
+ my $logfile = shift;
+ my $errorlog = shift;
+
+ $logfile = "/dev/null" if $logfile eq "";
+ $errorlog = "/dev/null" if $errorlog eq "";
+
+ # Change the current directory to /
+ chdir '/'
+ or die "$me: Error: Can't chdir to / ($!)";
+
+ # Turn off umask
+ umask 0;
+
+ # Redirect STDIN to /dev/null
+ open STDIN, '/dev/null'
+ or die "$me: Error: Can't redirect /dev/null ($!)";
+
+ # Redirect STDOUT to logfile
+ open STDOUT, ">>$logfile"
+ or die "$me: Error: Can't redirect stdout to $logfile ($!)";
+
+ # Redirect STDERR to errorlog
+ open STDERR, ">>$errorlog"
+ or die "$me: Error: Can't redirect stderr to $errorlog ($!)";
+
+ # Now fork the daemon
+ defined (my $pid = fork)
+ or die "$me: Error: Can't create daemon ($!)";
+
+ # Now the parent exits
+ exit if $pid;
+
+ # Set process to be session leader
+ setsid
+ or die "$me: Error: Can't start a new session ($!)";
+} # EnterDaemonMode
+
+sub OpenDB {
+ # Connect to database. Note this is using anonymous access (read only)
+ $DB = DBI->connect("DBI:Informix:$ecrdb")
+ or DBError "Unable to open database";
+ log_message "Opened $ecrdb database";
+
+ # Setup our select statement with placeholders
+ $statement = "select ";
+
+ # Build up the field list
+ my $first_time = 1;
+ foreach (@all_fields) {
+ if ($first_time) {
+ $first_time = 0;
+ $statement .= $_;
+ } else {
+ $statement .= ",$_";
+ } # if
+ } # foreach
+
+ # Now add the table and condition
+ $statement .= " from defect where pkey=?";
+
+ $sth = $DB->prepare ($statement)
+ or DBError "Unable to prepare statement", $statement;
+} # OpenDB
+
+sub CloseDB {
+ $DB->disconnect ()
+ or DBError "Unable to disconnect from database!";
+ verbose "Closed $ecrdb database";
+} # CloseDB
+
+sub Usage {
+ my $msg = shift;
+
+ print "$msg\n\n" if defined $msg;
+
+ print "Usage: $me [ -D ] [ -v ] [ -d ] [-p <port>] [ -m ] [ -q ]\n\n";
+ print "Where:\t-D\tEnter Daemon mode\n";
+ print "\t-v\tVerbose mode (Default off)\n";
+ print "\t-d\tDebug mode (Default off)\n";
+ print "\t-p\tPort number to use (Default 1500)\n";
+ print "\t-m\tMultithreaded (Default off)\n";
+ print "\t-q\tQuiet mode (Default on)\n";
+ exit 1;
+} # Usage
+
+sub GetECRRecord {
+ my $ecr = shift;
+
+ if ($ecr =~ /\D/) {
+ log_error "ECR $ecr is not numeric!";
+ return ();
+ } # if
+
+ my %fields;
+ my $record;
+ my $value;
+
+ $sth->execute ($ecr)
+ or DBError "Unable to execute statement", $statement;
+
+ my $row = $sth->fetchrow_arrayref;
+
+ if (!defined $row) {
+ # @row is empty if there was no ECR by that number
+ log_error "ECR $ecr not found!";
+ return ();
+ } # if
+
+ my @rows = @{$row};
+ foreach (@all_fields) {
+ my $value = shift @rows;
+
+ # Transform newlines to "\n" so the field is treated as one large field
+ $value =~ s/\n/\\n/g if defined $value;
+
+ # Perform some choice list field translations. Again this would be
+ # better done by doing database lookups to translate the enums...
+ $value = $defstatus [$value] if /defstatus/ and defined $value;
+ $value = $state [$value] if /state/ and defined $value;
+ $value = $priority [$value] if /priority/ and defined $value;
+ $value = $severity [$value] if /severity/ and defined $value;
+ # Fix description field back
+ if (/^description/) {
+ $_ = "description";
+ } # if
+ $fields {$_} = $value
+ } # foreach
+
+ return %fields;
+} # GetECRRecord
+
+sub ServiceClient {
+ my $ecrclient = shift;
+
+ # Service this client
+ my $hostinfo = gethostbyaddr ($ecrclient->peeraddr);
+ my $host = $hostinfo->name || $ecrclient->peerhost;
+
+ verbose "Connect from $host";
+ log_message "Waiting for command from $host";
+ while () {
+ GetClientAck ($ecrclient);
+ $_ = GetClientCmd ($ecrclient);
+ next unless /\S/; # Skip blank requests
+ last if /quit|exit/i;
+
+ if (/\*/) {
+ log_message "$host requests a list of all ECR #'s";
+ SendClientAck ($ecrclient);
+ ReturnAllECRNbrs ($ecrclient);
+ SendClientAck ($ecrclient);
+ next;
+ } # if
+
+ log_message "$host requests information about ECR $_";
+ SendClientAck ($ecrclient);
+ my %fields = GetECRRecord $_;
+
+ if (%fields) {
+ SendClientResponse ($ecrclient, "ecr: $_");
+ while (my ($key, $value) = each (%fields)) {
+ $value = !defined $value ? "" : $value;
+ SendClientResponse ($ecrclient, "$key: $value");
+ } # while
+ } else {
+ SendClientResponse ($ecrclient, "ECR $_ was not found");
+ } # if
+ SendClientAck ($ecrclient);
+ } # while
+
+ verbose "Closing connection from $host at client's request";
+ close $ecrclient;
+} # ServiceClient
+
+sub Funeral {
+ my $childpid = wait;
+ $SIG{CHLD} = \&Funeral;
+ log_message "Child has died" . ($? ? " with status $?" : "");
+} # Funeral
+
+sub GetRequest {
+ # Now wait for an incoming request
+ while ($ecrclient = $ecrserver->accept ()) {
+ my $hostinfo = gethostbyaddr ($ecrclient->peeraddr);
+ my $host = $hostinfo->name || $ecrclient->peerhost;
+ log_message "$host is requesting service";
+ if (defined ($multithreaded)) {
+ my $childpid;
+
+ log_message "Spawning child to handle request";
+
+ die "$me: ERROR: Can't fork: %!" unless defined ($childpid = fork ());
+
+ if ($childpid) {
+ # In parent - set up for clean up of child process
+ log_message "Parent produced child ($childpid)";
+ $SIG{CHLD} = \&Funeral;
+ log_message "Parent looking for another request to service";
+ } else {
+ # In child process - ServiceClient
+ $pid = $$;
+ debug "Child [$pid] has been born";
+ ServiceClient ($ecrclient);
+ log_message "Child finished servicing requests";
+ kill ("TERM", $$);
+ exit;
+ } # if
+ } else {
+ ServiceClient ($ecrclient);
+ } # if
+ } # while
+
+ close ($ecrserver);
+} # GetRequest
+
+sub ProcessRequests {
+ # The subroutine handles processing of requests by using a socket to
+ # communicate with clients.
+ $ecrserver = IO::Socket::INET->new (
+ Proto => 'tcp',
+ LocalPort => $port,
+ Listen => SOMAXCONN,
+ Reuse => 1
+ );
+
+ die "$me: Error: Could not create socket ($!)\n" unless $ecrserver;
+
+ verbose "ECR DB Server (ecrd V$ecrdversion) accepting clients on port $port";
+
+ GetRequest;
+} # ProcessRequests
+
+sub ReturnAllECRNbrs {
+ my $ecrclient = shift;
+
+ my $statement = "select pkey from defect";
+
+ my $sth = $DB->prepare ($statement)
+ or DBError "Unable to prepare statement", $statement;
+
+ $sth->execute ()
+ or DBError "Unable to execute statement", $statement;
+
+ log_message "Returning all ECR numbers...";
+ while (my @row = $sth->fetchrow_array) {
+ SendClientResponse ($ecrclient, $row [0]);
+ } # while
+
+ log_message "All ECR numbers returned";
+} # ReturnAllECRNbrs
+
+# Start main code
+# Reopen STDOUT.
+open STDOUT, ">-" or die "Unable to reopen STDOUT\n";
+
+# Set unbuffered output
+$| = 1;
+
+while ($ARGV [0]) {
+ if ($ARGV [0] eq "-D") {
+ $daemon_mode = 1;
+ } elsif ($ARGV [0] eq "-v") {
+ $verbose = 1;
+ undef ($quiet_mode);
+ } elsif ($ARGV [0] eq "-d") {
+ $debug = 1;
+ undef ($quiet_mode);
+ } elsif ($ARGV [0] eq "-m") {
+ $multithreaded = 1;
+ } elsif ($ARGV [0] eq "-q") {
+ $quiet_mode = 1;
+ undef ($verbose);
+ } elsif ($ARGV [0] eq "-p") {
+ shift @ARGV;
+ Usage "Must specify a port # after -p" if (!defined $ARGV [0]);
+ $port = $ARGV[0];
+ } else {
+ Usage "Unknown parameter found: " . $ARGV[0];
+ } # if
+
+ shift @ARGV;
+} # while
+
+my $tmp = (!defined $ENV {TMP}) ? "/tmp" : $ENV {TMP};
+my $ecrd_logfile = "$tmp/$me.log";
+my $ecrd_errfile = "$tmp/$me.err";
+
+EnterDaemonMode ($ecrd_logfile, $ecrd_logfile) if defined ($daemon_mode);
+
+OpenDB;
+
+# Set up signal handlers
+$SIG{ALRM} = \&timeout;
+$SIG{INT} = $SIG{QUIT} = \&interrupt;
+
+ProcessRequests;
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: ecrdesc
+# Description: This script will dump out the description for the ECR #(s)
+# passed in.
+# Author: Andrew@DeFaria.com
+# Created: Fri Jan 7 15:35:13 PST 2005
+# Language: Perl
+#
+# (c) Copyright 2005, LynxWorks Inc., all rights reserved
+#
+################################################################################
+use strict;
+use warnings;
+use DBI;
+
+my $DB;
+
+# Called when a database error has occurred
+sub DBError {
+ my $msg = shift;
+ my $statement = shift;
+
+ print $msg . "\nError #" . $DB->err . " " . $DB->errstr . "\n";
+
+ if (defined $statement) {
+ print "SQL Statement: $statement\n";
+ } # if
+
+ exit $DB->err;
+} # DBError
+
+# Connect to database. Note this is using anonymous access (read only)
+$DB = DBI->connect("DBI:Informix:lynxmigr1")
+ or DBError "Unable to open database";
+
+# Loop through ECR #s from the command line
+foreach my $ecr (@ARGV) {
+ print "ECR #: $ecr\n";
+
+ my $statement = "select description from defect where pkey=\"$ecr\"";
+ my $sth = $DB->prepare ($statement)
+ or DBError "Unable to prepare statement", $statement;
+
+ $sth->execute ()
+ or DBError "Unable to execute statement", $statement;
+
+ # Defect records are unique per pkey (AKA ECR) there for there will
+ # only be one entry in @row. Also the description is returned as one
+ # large string.
+ my @row = $sth->fetchrow_array;
+
+ if (!@row) {
+ # @row is empty if there was no ECR by that number
+ print "Nothing found!\n";
+ } else {
+ my $desc = pop @row;
+ print "Description:\n" . "-" x 80 . "\n" . $desc . "\n" . "-" x 80 . "\n";
+ } # if
+} # foreach
+
+$DB->disconnect;
+
+exit;
--- /dev/null
+###############################################################################
+#
+# File: $RCSfile: cq.conf,v $
+# Revision: $Revision: 1.5 $
+# Description: Config file for Clearquest
+# Author: Andrew@ClearSCM.com
+# Created: Fri Mar 11 17:58:31 PST 2011
+# Modified: $Date: 2013/01/12 18:24:50 $
+# Language: conf
+#
+# (c) Copyright 2011, ClearSCM, Inc., all rights reserved
+#
+###############################################################################
+
+# Common parms
+CQ_DATABASE: <default database>
+CQ_USERNAME: <default username>
+CQ_PASSWORD: <default password>
+CQ_DBSET: <default dbset>
+CQ_MODULE: <default module>
+
+# Parameters for Client/Server
+CQ_SERVER: <default server>
+CQ_PORT: <default port>
+CQ_MULTITHREADED: <default multithreaded>
+
+# Parameters for REST
+CQ_WEBHOST: http://$CQ_SERVER
+CQ_BASE_URL: $CQ_WEBHOST/cqweb/oslc
+CQ_URI: /cqweb/oslc/repo/$CQ_DBSET/db/$CQ_DATABASE
--- /dev/null
+ls=dir /w $*\r
+ll=dir /n /-c /q /ta $*\r
+ct=cleartool $*\r
+grep=find "$1" $*\r
+rm=del $*\r
+cp=copy $*\r
+perl=\\rtnlprod02\viewstore\PMO\CM_TOOLS\perl\bin\perl $*\r
+lsvob=cleartool lsvob $*\r
+llvob=cleartool lsvob -long $*\r
+lsview=cleartool lsview $*\r
+llview=cleartool lsview -long $*\r
+lsregion=cleartool lsregion $*\r
+register=cleartool register $*\r
+unregister=cleartool unregister $*\r
+mktag=cleartool mktag $*\r
+rmtag=cleartool rmtag $*\r
+setview=cleartool setview $*\r
+setcs=cleartool setcs $*\r
+edcs=cleartool edcs $*\r
+catcs=cleartool catcs $*\r
+pwv=cleartool pwv $*\r
+startview=cleartool startview $*\r
+endview=cleartool endview $*\r
+killview=cleartool endview -server $*\r
+rmtag=cleartool rmtag $*\r
+mktag=cleartool mktag $*\r
+mkview=cleartool mkview $*\r
+rmview=cleartool rmview $*\r
+lsregion=cleartool lsregion $*\r
+describe=cleartool describe $*\r
+vtree=cleartool lsvtree $*\r
+unco=cleartool unco -rm $*\r
+cdiff=cleartool diff $*\r
+space=cleartool space $*\r
+register=cleartool register $*\r
+unregister=cleartool unregister $*\r
+lslic=clearlicense -product ClearCase\r
+rellic=clearlicense -release -product ClearCase $*\r
+lstype=cleartool lstype $*\r
+lltype=cleartool lstype -long $*\r
+lsbranch=cleartoollstype brtype:$1\r
+llbranch=cleartool lstype -long brtype:$1\r
+lslabel=cleartool lstype lbtype:$1\r
+lllabel=cleartool lstype -long lbtype:$1\r
+lstrigger=cleartool lstype trtype:$1\r
+lltrigger=cleartool lstype -long trtype:$1\r
+lslock=cleartool lslock $*\r
+mt=multitool $*\r
+lspacket=multitool lspacket $*\r
+llpacket=multitool lspacket -long $*\r
+lsreplica=multitool lsreplica -vob $*\r
+llreplica=multitool lsreplica -long -vob $*\r
+lsepoch=multitool lsepoch -vob $*\r
+llepoch=multitool lsepoch -long -vob $*\r
+chepoch=multitool chepoch -vob $*\r
+syncreplica=multitool syncreplica $*\r
+\r
--- /dev/null
+###############################################################################
+#
+# File: $RCSfile: mail.conf,v $
+# Revision: $Revision: 1.2 $
+# Description: Config file for Mail.pm
+# Author: Andrew@DeFaria.com
+# Created: Wed Aug 1 09:16:42 MST 2007
+# Modified: $Date: 2010/12/15 23:42:33 $
+# Language: conf
+#
+# (c) Copyright 2007, ClearSCM, Inc., all rights reserved
+#
+###############################################################################
+SMTPHOST: defaria.com
+SMTPFROM: Andrew DeFaria <Andrew@DeFaria.com>
\ No newline at end of file
--- /dev/null
+# Triggers
+################################################################################
+#
+# File: triggers.dat
+# Description: Describes the triggers to be implemented.
+# Author: Andrew@DeFaria.com
+# Created: Mon Mar 15 08:48:24 PST 2004
+# Language: None
+#
+# (c) Copyright 2004, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+#
+# Only the following keywords are currently recognized:
+#
+# Trigger: Introduces the trigger and gives it its name
+# Description: Used for the trigger type's comment
+# Type: Type of trigger (so far they're all -element -all)
+# Opkinds: Operation kinds that will cause the trigger to fire
+# ScriptEngine: Currently only supporting ccperl (C:\Program
+# Files\Rational\ClearCase\bin\ccperl)
+# Script: Script to run (triggers)
+# Vobs: Can be either base, ucm, all or a list of vob tags.
+# If base is specified then the trigger is applied to all
+# base Clearcase vobs. If ucm is specified then the trigger
+# is applied to all ucm vobs. If all is specified (or if
+# Vobs is not present) then the trigger is applied to all
+# vobs (base and ucm). Otherwise the value is considered
+# a space separated list of vob tags (without the leading
+# "\") and the trigger is applied only to those vobs.
+# EndTrigger Ends this trigger definition.
+#
+################################################################################
+WinTriggerPath: \\vob8800sc\view\adefaria_tools\vob\adpscmtools\CCDB\triggers
+LinuxTriggerPath: /view/tools_view/vob/adpscmtools/CCDB/triggers
+
+Trigger: CCDB_STREAM
+ Description: Updates CCDB when a stream is made, removed, delivered to or rebased
+ Type: -ucm -all
+ Opkinds: -postop mkstream,rmstream,deliver_complete,rebase_complete
+ ScriptEngine: Perl
+ Script: Stream.pl
+ Vobs: ucm
+EndTrigger
+
+Trigger: CCDB_BASELINE
+ Description: Updates CCDB when baselines are made, completed or removed
+ Type: -ucm -all
+ Opkinds: -postop mkbl,mkbl_complete,rmbl
+ ScriptEngine: Perl
+ Script: Baseline.pl
+ Vobs: ucm
+EndTrigger
+
+Trigger: CCDB_ACTIVITY
+ Description: Updates CCDB when activities are made or removed
+ Type: -ucm -all
+ Opkinds: -postop mkactivity,rmactivity,chactivity
+ ScriptEngine: Perl
+ Script: Activity.pl
+ Vobs: ucm
+EndTrigger
+
+Trigger: CCDB_ELEMENT_PRE
+ Description: Updates CCDB when an element's version is changed
+ Type: -element -all
+ Opkinds: -preop checkin,uncheckout,rmver
+ ScriptEngine: Perl
+ Script: Element.pl
+ Vobs: base
+EndTrigger
+
+Trigger: CCDB_ELEMENT_POST
+ Description: Updates CCDB when an element's version is changed
+ Type: -element -all
+ Opkinds: -postop checkin,checkout,lnname,rmelem
+ ScriptEngine: Perl
+ Script: Element.pl
+ Vobs: base
+EndTrigger
--- /dev/null
+#!/usr/bin/bash
+################################################################################
+#
+# File: common
+# Description: Common functions for Korn Shell Scripts
+# Author: Andrew@DeFaria.com
+# Created: Tue Apr 15 14:20:02 PDT 1997
+# Modified:
+# Language: Korn Shell
+#
+# (c) Copyright 2001, Andrew@DeFaria.com, all rights reserved
+#
+################################################################################
+adm_fpath=${adm_fpath:-$adm_base/functions}
+
+case "$(uname -s)" in
+ HP-UX)
+ export VENDOR=HP
+ ;;
+
+ Sun*)
+ export VENDOR=Sun
+ ;;
+
+ *)
+ export VENDOR=Unknown
+ ;;
+esac
+
+modules="\
+ display\
+ utils\
+ "
+
+for module in $modules; do
+ if [ -f "$adm_fpath/$module" ]; then
+ . "$adm_fpath/$module"
+ else
+ echo "Internal Error: Function Module $adm_path/$module not found!"
+ exit 1
+ fi
+done
--- /dev/null
+#!/bin/ksh
+################################################################################
+#
+# File: date64
+# Description: Routines to handle the odd date arithmetic for the passwd(4)
+# file.
+# Author: Andrew@DeFaria.com
+# Created: Thu Oct 14 14:40:31 PDT 1999
+# Language: Korn Shell
+#
+# (c) Copyright 2001, Andrew@DeFaria.com, all rights reserved
+#
+################################################################################
+# Set me to command name
+me=$(basename $0)
+
+# Set adm_base
+adm_base=${adm_base:-$HOME/adm}
+
+# Set adm_fpath
+adm_fpath=${adm_fpath:-$adm_base/functions}
+
+# Source functions
+. $adm_fpath/common
+
+# Globals
+# Set up a the character map/base64 arrays for conversion
+base=64
+let index=00; character[$index]="."; let base64[$index]=$base*$index
+let index=01; character[$index]="/"; let base64[$index]=$base*$index
+let index=02; character[$index]="0"; let base64[$index]=$base*$index
+let index=03; character[$index]="1"; let base64[$index]=$base*$index
+let index=04; character[$index]="2"; let base64[$index]=$base*$index
+let index=05; character[$index]="3"; let base64[$index]=$base*$index
+let index=06; character[$index]="4"; let base64[$index]=$base*$index
+let index=07; character[$index]="5"; let base64[$index]=$base*$index
+let index=08; character[$index]="6"; let base64[$index]=$base*$index
+let index=09; character[$index]="7"; let base64[$index]=$base*$index
+let index=10; character[$index]="8"; let base64[$index]=$base*$index
+let index=11; character[$index]="9"; let base64[$index]=$base*$index
+let index=12; character[$index]="A"; let base64[$index]=$base*$index
+let index=13; character[$index]="B"; let base64[$index]=$base*$index
+let index=14; character[$index]="C"; let base64[$index]=$base*$index
+let index=15; character[$index]="D"; let base64[$index]=$base*$index
+let index=16; character[$index]="E"; let base64[$index]=$base*$index
+let index=17; character[$index]="F"; let base64[$index]=$base*$index
+let index=18; character[$index]="G"; let base64[$index]=$base*$index
+let index=19; character[$index]="H"; let base64[$index]=$base*$index
+let index=20; character[$index]="I"; let base64[$index]=$base*$index
+let index=21; character[$index]="J"; let base64[$index]=$base*$index
+let index=22; character[$index]="K"; let base64[$index]=$base*$index
+let index=23; character[$index]="L"; let base64[$index]=$base*$index
+let index=24; character[$index]="M"; let base64[$index]=$base*$index
+let index=25; character[$index]="N"; let base64[$index]=$base*$index
+let index=26; character[$index]="O"; let base64[$index]=$base*$index
+let index=27; character[$index]="P"; let base64[$index]=$base*$index
+let index=28; character[$index]="Q"; let base64[$index]=$base*$index
+let index=29; character[$index]="R"; let base64[$index]=$base*$index
+let index=30; character[$index]="S"; let base64[$index]=$base*$index
+let index=31; character[$index]="T"; let base64[$index]=$base*$index
+let index=32; character[$index]="U"; let base64[$index]=$base*$index
+let index=33; character[$index]="V"; let base64[$index]=$base*$index
+let index=34; character[$index]="W"; let base64[$index]=$base*$index
+let index=35; character[$index]="X"; let base64[$index]=$base*$index
+let index=36; character[$index]="Y"; let base64[$index]=$base*$index
+let index=37; character[$index]="Z"; let base64[$index]=$base*$index
+let index=38; character[$index]="a"; let base64[$index]=$base*$index
+let index=39; character[$index]="b"; let base64[$index]=$base*$index
+let index=40; character[$index]="c"; let base64[$index]=$base*$index
+let index=41; character[$index]="d"; let base64[$index]=$base*$index
+let index=42; character[$index]="e"; let base64[$index]=$base*$index
+let index=43; character[$index]="f"; let base64[$index]=$base*$index
+let index=44; character[$index]="g"; let base64[$index]=$base*$index
+let index=45; character[$index]="h"; let base64[$index]=$base*$index
+let index=46; character[$index]="i"; let base64[$index]=$base*$index
+let index=47; character[$index]="j"; let base64[$index]=$base*$index
+let index=48; character[$index]="k"; let base64[$index]=$base*$index
+let index=49; character[$index]="l"; let base64[$index]=$base*$index
+let index=50; character[$index]="m"; let base64[$index]=$base*$index
+let index=51; character[$index]="n"; let base64[$index]=$base*$index
+let index=52; character[$index]="o"; let base64[$index]=$base*$index
+let index=53; character[$index]="p"; let base64[$index]=$base*$index
+let index=54; character[$index]="q"; let base64[$index]=$base*$index
+let index=55; character[$index]="r"; let base64[$index]=$base*$index
+let index=56; character[$index]="s"; let base64[$index]=$base*$index
+let index=57; character[$index]="t"; let base64[$index]=$base*$index
+let index=58; character[$index]="u"; let base64[$index]=$base*$index
+let index=59; character[$index]="v"; let base64[$index]=$base*$index
+let index=60; character[$index]="w"; let base64[$index]=$base*$index
+let index=61; character[$index]="x"; let base64[$index]=$base*$index
+let index=62; character[$index]="y"; let base64[$index]=$base*$index
+let index=63; character[$index]="z"; let base64[$index]=$base*$index
+
+integer decimal_date=-1
+base64_date=""
+
+function date64_char_to_decimal {
+ debug "ENTER date64_char_to_decimal"
+ char="$1"
+ integer i=0
+
+ while [ $i -lt 64 ]; do
+ if [ "${character[i]}" = "$char" ]; then
+ break
+ fi
+ let i=i+1
+ done
+
+ if [ $i -eq 64 ]; then
+ print -u2 "$char not found!"
+ debug "RETURN -1 from date64_char_to_decimal"
+ return -1
+ else
+ debug "RETURN $i from date64_char_to_decimal"
+ return $i
+ fi
+} # date64_char_to_decimal
+
+function date64_to_decimal {
+ # This function accepts a 2 character "number of weeks" string as defined
+in
+ # passwd(4) under password aging. Specifically this string represents the
+ # number of weeks since 1/1/1970 that the password was last changed. This
+ # function will convert this value to a decimal number stored in the
+global
+ # decimal_date.
+ debug "ENTER date64_to_decimal ($1)"
+
+ # Assume failure
+ decimal_date=-1
+
+ datecode="$1"
+
+ first_char=$(print $datecode | sed 's/.$//')
+ second_char=$(print $datecode | sed 's/^.//')
+
+ date64_char_to_decimal $first_char
+ integer units_digit=$?
+ if [ $units_digit -eq 255 ]; then
+ error "Unable to translate the first_char \"$first_char\"" 0
+ debug "RETURN -1 from date64_to_decimal - invalid units digit"
+ return
+ fi
+
+ date64_char_to_decimal $second_char
+ integer tens_digit=$?
+ if [ $tens_digit -eq 255 ]; then
+ error "Unable to translate the second_char \"$second_char\"" 0
+ debug "RETURN -1 from date64_to_decimal - invalid tens digit"
+ return
+ fi
+
+ let decimal_date=tens_digit*64+units_digit
+ debug "RETURN $decimal_date from date64_to_decimal"
+} # date64_to_decimal
+
+function decimal_to_date64 {
+ # This function will convert a decimal number representing the number of
+ # weeks past 1/1/1970 and convert it to the odd base64 format described in
+ # passwd(4).
+ integer nbr=$1
+ debug "ENTER decimal_to_date64 ($nbr)"
+ i=63
+
+ while [ $nbr -lt ${base64[i]} ]; do
+ let i=i-1
+ done
+
+ let nbr=nbr-base64[i]
+
+ tens_digit=${character[i]}
+ units_digit=${character[nbr]}
+ base64_date="$units_digit$tens_digit"
+ debug "RETURN $base64_date from decimal_to_date64 ($nbr)"
+} # decimal_to_date64
--- /dev/null
+#!/bin/bash
+################################################################################
+#
+# File: display,v
+# Revision: 1.1.1.1
+# Description: Display functions for bash scripts
+# Author: Andrew@DeFaria.com
+# Created: Tue Apr 15 14:20:02 PDT 1997
+# Modified: 2007/05/17 07:45:48
+# Language: bash
+#
+# (c) Copyright 1997-2006, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+function display {
+ echo -e "$@"
+} # display
+
+function display_stderr {
+ echo -e "$@" 2> /dev/stderr
+} # display_stderr
+
+function error {
+ declare -i errornbr=$2
+
+ if [ $errornbr -ne 0 ]; then
+ display_stderr "$me: Error: $1 (Error: $2)"
+ exit $errornbr
+ else
+ display_stderr "$me: Error: $1"
+ fi
+} # error
+
+function warning {
+ declare -i warningnbr=$2
+
+ if [ $warningnbr -eq 0 ]; then
+ display_stderr "$me: Warning: $1"
+ else
+ display_stderr "$me: Warning: $1 (Warning: $2)"
+ fi
+} # warning
+
+function info {
+ display "$me: Info: $@"
+} # info
+
+function verbose {
+ if [ ! -z "$verbose" ]; then
+ display "$@"
+ fi
+} # verbose
+
+function debug {
+ if [ ! -z "$debug" ]; then
+ display_stderr "$@"
+ fi
+} # debug
--- /dev/null
+#!/bin/ksh
+################################################################################
+#
+# File: logs
+# Description: Functions for handling log files
+# Author: Andrew@DeFaria.com
+# Created: Thu Dec 9 10:05:09 PST 1999
+# Modified:
+# Language: Korn Shell
+#
+# (c) Copyright 2001, Andrew@DeFaria.com, all rights reserved
+#
+################################################################################
+function roll_log {
+ # roll_log: This function will roll a logfile
+ #
+ # Arguments:
+ # $1 Directory for log file
+ # $2 Name of log file
+ # $3 Name of backup log file
+ # $4 What activity is being logged
+ logdir=$1
+ logfile=$dir/$2
+ backup_logfile=$dir/$3
+ what=$4
+
+ if [ -f "$logfile" ]; then
+ cat $logfile >> $backup_logfile
+ print "$what log ($(hostname)) started on $(date)" > $logfile
+ fi
+} # roll_log
--- /dev/null
+#!/bin/ksh
+################################################################################
+#
+# File: tmpfiles
+# Description: Routines for handling temp files
+# Author: Andrew@DeFaria.com
+# Created: Tue Apr 15 14:20:02 PDT 1997
+# Modified:
+# Language: Korn Shell
+#
+# (c) Copyright 2001, Andrew@DeFaria.com, all rights reserved
+#
+################################################################################
+# This function will cleanup all temporary files used by the calling script
+# providing that they are all prefixed with tmpprefix.
+function cleanup {
+ debug "ENTER $0"
+ status=$?
+ if [ ! -z "$tmpprefix" -a $status -eq 0 ]; then
+ verbose "Cleaning up temp files..."
+ rm -f ${tmpprefix}*
+ else
+ debug "tmpprefix not set or status was not equal to 0 - no temporary
+files cleaned!"
+ fi
+
+ debug "EXIT $0"
+ exit $status
+} # cleanup
+
+function arm_trap {
+ debug "ENTER $0"
+ if [ -z "$tmpprefix" ]; then
+ warning "The environment variable tmpprefix has not neen set up!\n\
+Temporary files will not be cleaned up automatically!"
+ else
+ trap 'trap cleanup EXIT ERR' EXIT
+ debug "Cleanup will be called on EXIT or ERR signals"
+ fi
+
+ debug "EXIT $0"
+} # arm_trap
+
+function disarm_trap {
+ debug "ENTER $0"
+
+ trap 'trap - EXIT ERR' EXIT
+ debug "Cleanup will not be called on EXIT or ERR signals"
+ debug "EXIT $0"
+} # disarm_trap
--- /dev/null
+#!/bin/ksh
+################################################################################
+#
+# File: utils
+# Description: Miscellanous utility functions for Korn Shell Scripts
+# Author: Andrew@DeFaria.com
+# Created: Tue Apr 15 14:20:02 PDT 1997
+# Modified:
+# Language: Korn Shell
+#
+# (c) Copyright 2001, Andrew@DeFaria.com, all rights reserved
+#
+################################################################################
+if [ -x /usr/xpg4/bin/id ]; then
+ ID=/usr/xpg4/bin/id
+else
+ ID=/usr/bin/id
+fi
+
+function is_root {
+ if [ $($ID -u) -eq 0 ]; then
+ return 0
+ else
+ return 1
+ fi
+} # is_root
+
+function is_not_root {
+ if [ $($ID -u) -eq 0 ]; then
+ return 1
+ else
+ return 0
+ fi
+} # is_not_root
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: $RCSfile: BinMerge.pm,v $
+# Revision: $Revision: 1.4 $
+# Description: This module will perform a merge checking for any merge
+# conflicts and grouping them at the end. This allows the
+# majority of a large merge to happen and the user can resolve
+# the conflicts at a later time.
+#
+# This module also assists in performing binary merges for the
+# common case. With a binary merge one cannot easily merge the
+# binary code. Most often it's a sitatution where the user will
+# either accept the source or the destination binary file as
+# a whole. In cases where there is only a 2 way merge, this
+# script offers the user the choice to accept 1 binary file
+# or the other or to abort this binary merge. Binary merges
+# conflicts greater than 2 way are not handled.
+#
+# This was made into a module so that it could be easily called
+# from UCMCustom.pl. There is also a corresponding bin_merge
+# script which essentially calls this module
+#
+# Dependencies: This module depends on PerlTk. As such it must be run
+# from ccperl or a Perl that has the PerlTk module
+# installed. Additionally it uses the Clearcase
+# cleartool command which is assumed to be in PATH.
+# Author: Andrew@ClearSCM.com
+# Created: Thu Nov 3 10:55:51 PST 2005
+# Modified: $Date: 2011/03/10 23:47:31 $
+# Language: perl
+#
+# (c) Copyright 2005, ClearSCM, Inc. all rights reserved
+#
+################################################################################
+package BinMerge;
+
+use strict;
+use warnings;
+
+use base 'Exporter';
+use File::Spec;
+use Tk;
+use Tk::Dialog;
+use OSDep;
+
+our @EXPORT = qw (
+ Merge
+ Rebase
+);
+
+our ($me);
+
+BEGIN {
+ # Extract relative path and basename from script name.
+ $0 =~ /(.*)[\/\\](.*)/;
+
+ $me = (!defined $2) ? $0 : $2;
+ $me =~ s/\.pl$//;
+
+ # Remove .pl for Perl scripts that have that extension
+ $me =~ s/\.pl$//;
+} # BEGIN
+
+ use Display;
+ use Logger;
+ use OSDep;
+
+ my $version = "1.0";
+ my $user = $ENV {USERNAME};
+
+ my $main;
+ my $selection_file = "$me.selection.$$";
+
+ sub ReadFile {
+ my $filename = shift;
+
+ # Sometimes people foolishly undef $/
+ local $/ = "\n";
+
+ open my $file, '<', $filename
+ or error "Unable to open $filename ($!)", 1;
+
+ my @lines = <$file>;
+
+ close $file;
+
+ my @cleansed_lines;
+
+ foreach (@lines) {
+ chomp;
+ chop if /\r/;
+ push @cleansed_lines, $_ if !/^#/; # Discard comment lines
+ } # foreach
+
+ return @cleansed_lines;
+ } # ReadFile
+
+ sub Error {
+ my $msg = shift;
+
+ my $err = $main->Dialog (
+ -title => "Error",
+ -text => $msg,
+ -buttons => [ "OK" ]
+ );
+
+ $err->Show;
+
+ return;
+ } # Error
+
+ sub CheckSelection {
+ my $list = shift;
+
+ my @entries = $list->curselection;
+
+ if (scalar @entries == 0) {
+ Error "Nothing selected!";
+ return;
+ } # if
+
+ my $selected = $list->get ($entries [0]);
+
+ # Write selection out to file and exit
+ open my $file, '>', $selection_file
+ or die "Unable to open $selection_file\n";
+
+ print $file "$selected\n";
+
+ close $file;
+
+ # Close prompt window
+ $main->destroy;
+
+ return;
+ } # CheckSelection
+
+ sub Help {
+ my $text;
+
+ $text = "A merge conflict has been detected between two binary files. ";
+ $text .= "Please pick the version that you want to be the result of this ";
+ $text .= "merge.\n\nNote you can pick any of these versions and the result ";
+ $text .= "will be that that version will be considered the new version ";
+ $text .= "overwriting the previous version.\n\nIf this is not what you want ";
+ $text .= "then select the Cancel button and regenerate this binary file ";
+ $text .= "so that it is the result of what you want for this merge.\n\n";
+ $text .= "Copyright ? 2005 - All rights reserved\n";
+ $text .= "Andrew DeFaria <Andrew\@ClearSCM.com>";
+
+ my $desc = $main->Dialog (
+ -title => "Help",
+ -text => $text,
+ -buttons => [ "OK" ]
+ );
+
+ $desc->Show;
+
+ return;
+ } # Help
+
+ sub Cancel {
+ $main->destroy;
+
+ return;
+ } # Cancel
+
+ sub VersionTree {
+ my $file = shift;
+
+ my $cmd = "cleartool lsvtree -graphical $file";
+
+ if ($^O =~ /mswin|cygwin/i) {
+ system "start /b $cmd";
+ } else {
+ my $pid = fork;
+
+ return if $pid;
+
+ system $cmd;
+ exit;
+ } # if
+
+ return;
+ } # VersionTree
+
+ # Create a ListBox widget in $parent, dynamically sizing it to the length of
+ # the longest entry in @list.
+ sub CreateList {
+ my ($parent, @list) = @_;
+
+ my $list = $parent->Scrolled ("Listbox",
+ -scrollbars => "osoe",
+ -width => 70,
+ -height => 5,
+ )->pack;
+
+ # Insert entries from @list into the new ListBox, $list
+ foreach (@list) {
+ $list->insert ("end", $_);
+ } # foreach
+
+ $list->pack;
+
+ return $list;
+ } # CreateList
+
+ sub CreateButtons {
+ my ($parent, $list, $file) = @_;
+ my $one = $parent->Frame->pack (-side => "left", -pady => 2, -padx => 2);
+ my $two = $parent->Frame->pack (-side => "left", -pady => 2, -padx => 2);
+ my $three = $parent->Frame->pack (-side => "left", -pady => 2, -padx => 2);
+ my $four = $parent->Frame->pack (-side => "left", -pady => 2, -padx => 2);
+
+ my $ok = $one->Button (
+ -text => "OK",
+ -command => [ \&CheckSelection, $list ]
+ )->pack;
+
+ my $cancel = $two->Button (
+ -text => "Cancel",
+ -command => [ \&Cancel ]
+ )->pack;
+
+ my $help = $three->Button (
+ -text => "Help",
+ -command => \&Help
+ )->pack;
+
+ my $vtree = $four->Button (
+ -text => "Version Tree",
+ -command => [ \&VersionTree, $file ]
+ )->pack;
+
+ return;
+ } # CreateButtons
+
+ sub PromptUser {
+ my ($element, @versions) = @_;
+
+ debug "ENTER: PromptUser";
+
+ # Create main window
+ $main = MainWindow->new;
+
+ # Title window
+ $main->title ("Resolve merge conflict for binary element");
+
+ # Create the main window using containers
+ my $top = $main->Frame->pack (-side => "top", -fill => "x");
+ my $prompt = $top->Frame->pack (-side => "left", -pady => 5, -padx => 5);
+ my $list = $main->Frame->pack (-side => "left");
+ my $buttons = $list->Frame->pack (-side => "bottom");
+
+ # Label it
+ my $prompt_str = <<"END";
+A binary merge conflict has been detected between two versions of
+
+$element
+
+Please pick the version that you want to be the result of this merge. Note you
+can pick any of these versions and the result will be that that version will be
+considered the new version overwriting the previous version. If this is not what
+you want then select the Cancel button here and regenerate this binary file so
+that it is the result of what you want for this merge.
+END
+
+ $prompt->Message (-text => $prompt_str, -width => 500)->pack;
+
+ my $version_list = CreateList $list, @versions;
+
+ CreateButtons $buttons, $version_list, $element;
+
+ # Make sure the window pops to the top
+ # Trying really hard... :-)
+ $main->update;
+ $main->deiconify;
+ $main->update;
+ $main->raise;
+ $main->update;
+ $main->focusForce;
+ $main->update;
+
+ MainLoop;
+
+ open my $result, '<', $selection_file
+ or return;
+
+ my @lines = <$result>;
+
+ close $result;
+
+ unlink $selection_file;
+
+ if (@lines) {
+ chomp $lines[0];
+ return $lines[0];
+ } else {
+ return;
+ } # if
+
+ return;
+ } # PromptUser
+
+ # The merging of directories could, in theory, unearth other elements inside
+ # those directories thus causing further merging. Here we keep merging
+ # directories until there are no directories to merge.
+ sub MergeDirectories {
+ my ($log, $path, $branch) = @_;
+
+ my $cmds = "$me.$$.cmds";
+ my $cmd = "cleartool findmerge $path -nc -type d -fversion $branch " .
+ "-log $cmds -print > $NULL 2>&1";
+
+ debug "ENTER: MergeDirectories (<log>, $path, $branch)";
+
+ my @lines;
+
+ while () {
+ $log->msg ("Searching for directories that need merging...");
+
+ debug "Performing: $cmd";
+
+ my $status = $log->logcmd ($cmd);
+
+ return $status if $status != 0;
+
+ @lines = ReadFile $cmds;
+
+ last if scalar @lines == 0;
+
+ $log->msg ("Performing directory merges...");
+
+ foreach (@lines) {
+ $log->log ($_);
+ debug "Performing: $_";
+ $status = $log->logcmd ($_);
+
+ return $status if $status != 0;
+ } # foreach
+ } # while
+
+ $log->msg ("All directories merged.");
+
+ # Clean up
+ unlink $cmds;
+
+ debug "EXIT: MergeDirectories (<log>, $path, $branch)";
+
+ return 0;
+ } # MergeDirectories
+
+ # Here we'll attempt to merge file individually using -abort. This tells
+ # cleartool findmerge to only merge that which is can automatically merge. For
+ # every merge failure we'll push an entry onto @merge_conflicts.
+ sub MergeFiles {
+ my ($log, $path, $branch) = @_;
+
+ my $cmds = "$me.$$.cmds";
+ my $cmd = "cleartool findmerge $path -nc -type f -fversion $branch " .
+ "-log $cmds -print > $NULL 2>&1";
+
+ debug "ENTER: MergeFiles (<log>, $path, $branch)";
+
+ $log->msg ("Merging files...");
+
+ $log->logcmd ($cmd);
+
+ my @lines = ReadFile $cmds;
+ my @merge_conflicts;
+
+ foreach my $file_merge_cmd (@lines) {
+ my %merge_conflict;
+
+ my $file_to_merge;
+
+ if ($file_merge_cmd =~ /cleartool findmerge (.*) -fver/) {
+ $file_to_merge = $1;
+ } # if
+
+ # Add -abort to this variable, which use for execution. We keep
+ # the old variable to put in the return array.
+ my $file_merge_cmd_abort = "$file_merge_cmd -abort 2>&1";
+
+ debug "Performing $file_merge_cmd_abort";
+ $log->msg ($file_merge_cmd_abort);
+
+ # Capture the output from the merge and parse it. If there's
+ # just a merge conflict then "*** No Automatic Decision
+ # possible" and "merge: Warning: *** Aborting.." are present in
+ # the output. If the merge fails because of binary files then
+ # nothing is in the output. Either way, if Clearcase is unable
+ # to merge the status returned is non zero. We can then
+ # differentiate between resolvable merge conflicts and
+ # unresolvable merge conflicts (binary files). Format
+ # %merge_conflicts to indicate the type and push it on
+ # @merge_conflicts to return to the caller.
+ #
+ # Also find merges that will not work because the element is
+ # checked out reserved somewhere else.
+ my @output = `$file_merge_cmd_abort`;
+ my $status = $?;
+
+ # Put output in the logfile
+ chomp @output;
+ foreach (@output) {
+ $log->log ($_);
+ } # foreach
+
+ if ($status == 0) {
+ # If $status eq 0 then the merge was successful! Next merge!
+ $log->msg ("Auto merged $file_to_merge");
+ next;
+ } # if
+
+ # Check for errors
+ my @errors = grep {/\*\*\* /} @output;
+ my @reserved = grep {/is checked out reserved/} @output;
+
+ if (scalar @reserved > 0) {
+ if ($reserved [0] =~ /view (\S+)\./) {
+ $log->err ("Unable to merge $file_to_merge because it is checked out reserved in the view $1");
+ } # if
+
+ next;
+ } # if
+
+ $merge_conflict {cmd} = $file_merge_cmd;
+
+ # Differentiate between binary merge conflicts and non binary
+ # merge conflicts
+ if (scalar @errors > 0) {
+ $merge_conflict {type} = "regular";
+ $log->msg ("Delaying regular conflicting merge for " . $file_to_merge);
+ } else {
+ $log->msg ("Delaying binary merge for " . $file_to_merge);
+ $merge_conflict {type} = "binary";
+ } # if
+
+ push @merge_conflicts, \%merge_conflict;
+ } # foreach
+
+ my $nbr_conflicts = scalar @merge_conflicts;
+
+ if ($nbr_conflicts == 0) {
+ $log->msg ("All files merged");
+ } elsif ($nbr_conflicts == 1) {
+ $log->msg ("$nbr_conflicts merge conflict found");
+ } else {
+ $log->msg ("$nbr_conflicts merge conflicts found");
+ } # if
+
+ # Clean up
+ unlink $cmds;
+
+ debug "EXIT: MergeFiles (<log>, $path, $branch)";
+
+ return @merge_conflicts;
+ } # MergeFiles
+
+ sub GetRebaseDirs {
+ my $log = shift;
+ my $baseline = shift;
+
+ $log->msg ("Finding directories that need rebasing...");
+
+ my $cmd = "cleartool rebase -long -preview ";
+
+ if (!defined $baseline) {
+ $cmd .= "-recommended";
+ } else {
+ $cmd .= "-baseline $baseline";
+ } # if
+
+ $log->msg ("Performing command: $cmd");
+
+ my @output = `$cmd`;
+ chomp @output;
+
+ my %rebase_dirs;
+
+ return %rebase_dirs if $? != 0;
+
+ # Now parse the files to be merged collecting information
+ foreach (@output) {
+ if (/\s*(\S*)\@\@(\S*)/) {
+ my $element = $1;
+ my $ver = $2;
+
+ # Directories only
+ next if !-d $element;
+
+ $log->msg ("Directory Element: $element Version: $ver");
+ $rebase_dirs {$element} = $ver;
+ } # if
+ } # foreach
+
+ return %rebase_dirs;
+ } # GetRebaseDirs
+
+ sub GetRebaseFiles {
+ my $log = shift;
+ my $baseline = shift;
+
+ $log->msg ("Finding files that need rebasing...");
+
+ my $cmd = "cleartool rebase -long -preview ";
+
+ if (!defined $baseline) {
+ $cmd .= "-recommended";
+ } else {
+ $cmd .= "-baseline $baseline";
+ } # if
+
+ $log->msg ("Performing command: $cmd");
+
+ my @output = `$cmd`;
+
+ return if $? != 0;
+
+ chomp @output;
+
+ my %rebase_files;
+
+ # Now parse the files to be merged collecting information
+ foreach (@output) {
+ if (/\s*(\S*)\@\@(\S*)/) {
+ my $element = $1;
+ my $ver = $2;
+
+ # Files only
+ next if !-f $element;
+
+ $log->msg ("Element: $element Version: $ver");
+ $rebase_files {$element} = $ver;
+ } # if
+ } # foreach
+
+ return %rebase_files;
+ } # GetRebaseFiles
+
+ sub RebaseDirectories {
+ my $log = shift;
+ my $baseline = shift;;
+
+ debug "ENTER: RebaseDirectories";
+
+ $log->msg ("Rebasing directories");
+
+ my $rebase_status = 0;
+ my %rebase_dirs;
+
+ # Keep rebasing directories until there are no more
+ while (%rebase_dirs = GetRebaseDirs $log, $baseline) {
+ foreach my $element (keys %rebase_dirs) {
+ # First checkout file if necessary - ignore errors
+ my @output = `cleartool checkout -nc $element > $NULL 2>&1`;
+
+ my $cmd = "cleartool merge -abort -to $element -version ${rebase_dirs {$element}} 2>&1";
+
+ @output = `$cmd`;
+ my $status = $?;
+
+ # Put output in the logfile
+ chomp @output;
+
+ foreach (@output) {
+ $log->log ($_);
+ } # foreach
+
+ if ($status == 0) {
+ # If $status eq 0 then the merge was successful! Next merge!
+ $log->msg ("Auto merged $element");
+ next;
+ } # if
+
+ # Check for errors
+ my @errors = grep {/\*\*\* /} @output;
+ my @reserved = grep {/is checked out reserved/} @output;
+
+ # TODO: This is broke!
+ my $file_to_merge;
+ if (scalar @reserved > 0) {
+ if ($reserved [0] =~ /view (\S+)\./) {
+ $log->err ("Unable to merge $file_to_merge because it is checked out reserved in the view $1");
+ $rebase_status++;
+ } # if
+
+ next;
+ } # if
+ } # foreach
+ } # while
+
+ debug "Returning $rebase_status from RebaseDirectories";
+ return $rebase_status;
+ } # RebaseDirectories
+
+ sub RebaseFiles {
+ my ($log, $baseline, %rebase_elements) = @_;
+
+ debug "ENTER: RebaseFiles";
+
+ # TODO: This is broke too
+ my @merge_conflicts;
+
+ $log->msg ("Rebasing elements");
+
+ foreach my $element (keys %rebase_elements) {
+ # First checkout file if necessary - ignore errors
+ my @output = `cleartool checkout -nc $element > $NULL 2>&1`;
+
+ my $cmd = "cleartool merge -abort -to $element -version ${rebase_elements {$element}} 2>&1";
+
+ @output = `$cmd`;
+ my $status = $?;
+
+ # Put output in the logfile
+ chomp @output;
+ foreach (@output) {
+ $log->log ($_);
+ } # foreach
+
+ if ($status == 0) {
+ # If $status eq 0 then the merge was successful! Next merge!
+ $log->msg ("Auto merged $element");
+ next;
+ } # if
+
+ # Check for errors
+ my @errors = grep {/\*\*\* /} @output;
+ my @reserved = grep {/is checked out reserved/} @output;
+
+ # TODO: This is broke too
+ my ($file_to_merge, $merge_conflict, %merge_conflict, @merge_conflicts);
+
+ if (scalar @reserved > 0) {
+ if ($reserved [0] =~ /view (\S+)\./) {
+ $log->err ("Unable to merge $file_to_merge because it is checked out reserved in the view $1");
+ } # if
+
+ next;
+ } # if
+
+ # Differentiate between binary merge conflicts and non binary
+ # merge conflicts
+ if (scalar @errors > 0) {
+ $merge_conflict {type} = "regular";
+ $log->msg ("Delaying regular conflicting merge for " . $element);
+ } else {
+ $log->msg ("Delaying binary merge for " . $element);
+ $merge_conflict {type} = "binary";
+ } # if
+
+ push @merge_conflicts, \%merge_conflict;
+ } # foreach
+
+ my $nbr_conflicts = scalar @merge_conflicts;
+
+ if ($nbr_conflicts == 0) {
+ $log->msg ("All files merged");
+ } elsif ($nbr_conflicts == 1) {
+ $log->msg ("$nbr_conflicts merge conflict found");
+ } else {
+ $log->msg ("$nbr_conflicts merge conflicts found");
+ } # if
+
+ debug "EXIT: RebaseFiles";
+
+ return @merge_conflicts;
+ } # RebaseFiles
+
+ sub Rebase {
+ my ($baseline, $verbose, $debug) = @_;
+
+ if ($verbose) {
+ Display::set_verbose;
+ Logger::set_verbose;
+ } # if
+
+ set_debug if $debug;
+
+ my $log = Logger->new (
+ name => "$me.$$",
+ disposition => "temp",
+ path => $ENV{TMP}
+ );
+
+ $log->msg ("BinMerge (rebase) $version started at " . localtime);
+
+ if (!defined $baseline) {
+ $log->msg ("Baseline: RECOMMENDED");
+ } else {
+ $log->msg ("Baseline: $baseline");
+ } # if
+
+ my $rebase_status = RebaseDirectories $log, $baseline;
+
+ my @merge_conflicts = RebaseFiles $log, $baseline;
+
+ # more to come...
+ return;
+ } # Rebase
+
+ sub Merge {
+ my ($branch, $path, $verbose, $debug) = @_;
+
+ if ($verbose) {
+ Display::set_verbose;
+ Logger::set_verbose;
+ } # if
+
+ set_debug if $debug;
+
+ error "Must specify a branch" if !defined $branch;
+ $path = "." if !defined $path;
+
+ my $log = Logger->new (
+ name => "$me.$$",
+ disposition => "temp",
+ path => $ENV{TMP}
+ );
+
+ $log->msg ("BinMerge $version started at " . localtime);
+ my $merge_status = 0;
+
+ $merge_status = MergeDirectories $log, $path, $branch;
+
+ my @merge_conflicts = MergeFiles $log, $path, $branch;
+
+ my (@binary_merge_conflicts, @text_merge_conflicts);
+ my $merge_conflict;
+
+ # Separate the bin merges from the text merges.
+ while (@merge_conflicts) {
+ my %merge_conflict = %{shift @merge_conflicts};
+
+ if ($merge_conflict {type} eq "binary") {
+ # Since we can't merge binary files, change -merge to
+ # -print. Later we'll use the -print output to present the
+ # user options...
+ $merge_conflict {cmd} =~ s/ -merge / -print /;
+ push @binary_merge_conflicts, $merge_conflict {cmd};
+ } else {
+ # For text merges we can merge but we want to merge
+ # graphically.
+ $merge_conflict {cmd} =~ s/ -merge / -gmerge /;
+ push @text_merge_conflicts, $merge_conflict {cmd};
+ } # if
+ } # while;
+
+ # Now process the text merges
+ foreach my $merge_conflict (@text_merge_conflicts) {
+ # Now try the merge so that diffmerge comes up allowing the user
+ # to resolve the conflicts for this element.
+ my $file_to_merge;
+
+ if ($merge_conflict =~ /cleartool findmerge (.*) -fver/) {
+ $file_to_merge = $1;
+ } # if
+
+ $file_to_merge =~ s/\\\\/\\/g;
+
+ debug "Performing $merge_conflict";
+ my $status = $log->logcmd ("$merge_conflict 2>&1");
+
+ if ($status != 0) {
+ $log->err ("$user did not resolve merge conflicts in $file_to_merge");
+ $merge_status++;
+ } else {
+ $log->msg ("$user resolved conflicts in merge of $file_to_merge");
+ } # if
+ } # foreach
+
+ # Now process the binary ones...
+ foreach my $merge_conflict (@binary_merge_conflicts) {
+ # Now try to handle the binary merge conflicts. Best we can do
+ # is to present the user the with the various versions that
+ # could be taken as a whole along with an option to not
+ # merge. If they select a specific version then we simply draw a
+ # merge arrow.
+
+ my @selections;
+
+ # First let's do the merge command again capturing the output
+ # which has a format like:
+ #
+ # Needs Merge "firefox.exe" [to \main\adefaria_Andrew\CHECKEDOUT
+ # from \main\Andrew_Integration\2 base \main\adefaria_Andrew\1]
+ #
+ # From this we'll get the $from and $to to present to the user.
+ my $file_to_merge;
+
+ if ($merge_conflict =~ /cleartool findmerge (.*) -fver/) {
+ $file_to_merge = $1;
+ } # if
+
+ debug "Performing $merge_conflict";
+ my @output = `$merge_conflict 2>&1`;
+
+ my ($to, $from);
+
+ if ($output [0] =~ /to (\S*) from (\S*)/) {
+ $to = $1;
+ $from = $2;
+ } # if
+
+ push @selections, $from;
+ push @selections, $to;
+
+ my $choice = PromptUser $file_to_merge, @selections;
+
+ if (!defined $choice) {
+ $log->err ("$user aborted binary merge of $file_to_merge");
+ next;
+ } # if
+
+ chomp $choice;
+ # I don't know why the above doesn't remove the trailing \n so let's
+ # chop it off if it exists!
+ chop $choice if $choice =~ /\n/;
+
+ my $cmd;
+
+ # At this point the merge process has checked out the file in
+ # the current view but is unable to perform the merge because
+ # this is a binary file. If the user chooses the $from version
+ # then they are saying that the $from version should be brought
+ # into the current view and a merge arrow drawn from $from ->
+ # $to.
+ #
+ # If, however, they choose the CHECKEDOUT version then what we
+ # want to do is to cancel the current checkout and draw a merge
+ # arrow from the predecessor to $to.
+ if ($choice eq $from) {
+ # Need to copy the $from version to the checkedout version here.
+ debug "Copying $file_to_merge\@\@$choice to current view";
+ open my $from, '<', "$file_to_merge\@\@$choice"
+ or error "Unable to open $file_to_merge\@\@$choice", 1;
+ binmode $from;
+
+ open my $to, '>', "$file_to_merge"
+ or error "Unable to open $file_to_merge\@\@$to", 2;
+ binmode $to;
+
+ while (<$from>) {
+ print $to $_;
+ } # while
+
+ close $from;
+ close $to;
+
+ $log->msg ("$user chose to link from $choice -> $file_to_merge" .
+ " in the current view");
+ $cmd = "cleartool merge -to \"$file_to_merge\"" .
+ " -ndata \"$file_to_merge\@\@$choice\"";
+ } else {
+ # Need to cancel the checkout then determine what version
+ # Clearcase reverts to. WARNING: This might doesn't work
+ # for a snapshot view.
+ debug "Canceling checkout for $file_to_merge";
+ @output = `cleartool unco -rm $file_to_merge 2>&1`;
+
+ error "Unable to cancel checkout of $file_to_merge", 3 if $? != 0;
+
+ @output = `cleartool ls -s $file_to_merge`;
+
+ chomp $output [0];
+
+ if ($output [0] =~ /\@\@(.*)/) {
+ $choice = $1;
+ } # if
+
+ debug "Drawing merge arrow from $file_to_merge\@\@$from -> $choice";
+ $log->msg ("$user chose to link $file_to_merge from $from -> $choice");
+ $cmd = "cleartool merge -to \"$file_to_merge\"\@\@$choice\" -ndata \"$file_to_merge\@\@$from\"";
+ } # if
+
+ # Draw merge arrow
+ my $status = $log->logcmd ($cmd);
+
+ error "Unable to draw merge arrow ($cmd)" if $status != 0;
+
+ $merge_status += $status;
+ } # foreach
+
+ if ($merge_status > 0) {
+ $log->err ("There were problems with the merge. Please review " .
+ $log->fullname . " for more infomation");
+ } # if
+
+ return $merge_status
+ } # Merge
+
+1;
--- /dev/null
+=pod
+
+=head1 NAME $RCSfile: Clearcase.pm,v $
+
+Object oriented interface to Clearcase.
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.43 $
+
+=item Created
+
+Tue Dec 4 17:33:43 MST 2007
+
+=item Modified
+
+$Date: 2011/11/16 18:27:37 $
+
+=back
+
+=head1 SYNOPSIS
+
+Provides access to global Clearcase information in an object oriented manner as
+well as an interface to cleartool.
+
+ # Access some compile time global settings:
+ display "View Drive: $Clearcase::VIEW_DRIVE";
+ display "Vob Tag Prefix: $Clearcase::VOBTAG_PREFIX";
+
+ # Access some run time global information through the default object
+ display "Client: $Clearcase::CC->client";
+ display "Region: $Clearcase::CC->region";
+ display "Registry host: $Clearcase::CC->registry_host";
+
+ # List all vobs using execute method of the default object";
+ my ($status, @vobs) = $Clearcase::CC->execute ("lsvob -s");
+
+ display $_ foreach (@vobs) if $status == 0;
+
+=head1 DESCRIPTION
+
+This module, and others below the Clearcase directory, implement an object
+oriented approach to Clearcase. In general Clearcase entities are made into
+objects that can be manipulated easily in Perl. This module is the main or
+global module. Contained herein are members and methods of a general or global
+nature. Also contained here is an IPC interface to cleartool such that cleartool
+runs in the background and commands are fed to it via the execute method. When
+making repeated calls to cleartool this can result in a substantial savings of
+time as most operating systems' fork/execute sequence is time consuming. Factors
+of 8 fold improvement have been measured.
+
+Additionally a global variable, $CC, is implemented from this module such that
+you should not need to instantiate another one, though you could.
+
+=head1 ROUTINES
+
+The following routines are exported:
+
+=cut
+
+package Clearcase;
+
+use strict;
+use warnings;
+
+use base 'Exporter';
+
+use Carp;
+
+use IPC::Open3;
+
+use OSDep;
+use Display;
+
+my ($clearpid, $clearin, $clearout, $oldHandler);
+
+our $VIEW_DRIVE = 'M';
+our $VOB_MOUNT = 'vob';
+our $WIN_VOB_PREFIX = '\\';
+our $SFX = $ENV{CLEARCASE_XN_SFX} ? $ENV{CLEARCASE_XN_SFX} : '@@';
+
+our $VOBTAG_PREFIX = ($ARCH eq 'windows' or $ARCH eq 'cygwin')
+ ? $WIN_VOB_PREFIX
+ : "/$VOB_MOUNT/";
+our $VIEWTAG_PREFIX = ($ARCH eq 'windows' or $ARCH eq 'cygwin')
+ ? "$VIEW_DRIVE:"
+ : "${SEPARATOR}view";
+
+our ($CCHOME, $COUNTDB);
+
+our $CC;
+
+our @EXPORT_OK = qw (
+ $CC
+ $CCHOME
+ $COUNTDB
+ $SFX
+ $VIEW_DRIVE
+ $VIEWTAG_PREFIX
+ $VOB_MOUNT
+ $VOBTAG_PREFIX
+ $WIN_VOB_PREFIX
+);
+
+BEGIN {
+ # Find executables that we rely on
+ if ($ARCH eq 'windows' or $ARCH eq 'cygwin') {
+ # Should really go to the registry for this...
+
+ # We can go to the registry pretty easy in Cygwin but I'm not sure how to do
+ # that in plain old Windows. Most people either have Clearcase installed on
+ # the C drive or commonly on the D drive on servers. So we'll look at both.
+ $CCHOME = 'C:\\Program Files\\Rational\\Clearcase';
+
+ $CCHOME = 'D:\\Program Files\\Rational\\Clearcase'
+ unless -d $CCHOME;
+
+ error 'Unable to figure out where Clearcase is installed', 1
+ unless -d $CCHOME;
+
+ $COUNTDB = "$CCHOME\\etc\\utils\\countdb.exe";
+ } else {
+ $CCHOME = '/opt/rational/clearcase';
+ $COUNTDB = "$CCHOME/etc/utils/countdb";
+ } # if
+
+ #error "Unable to find countdb ($COUNTDB)", 2
+ #if ! -f $COUNTDB;
+} # BEGIN
+
+sub DESTROY {
+ my $exitStatus = $?;
+
+ if ($clearpid) {
+ # Exit cleartool process
+ print $clearin "exit\n";
+
+ waitpid $clearpid, 0;
+ } # if
+
+ local $? = $exitStatus;
+
+ # Call old signal handler (if any)
+ &$oldHandler if $oldHandler;
+
+ return;
+} # DESTROY
+
+# Save old interrupt handler
+$oldHandler = $SIG{INT};
+
+# Set interrupt handler
+local $SIG{INT} = \&Clearcase::DESTROY;
+
+sub _formatOpts {
+ my (%opts) = @_;
+
+ my $opts = '';
+
+ foreach (keys %opts) {
+ $opts .= "$_ ";
+ $opts .= "$opts{$_} "
+ if $opts{$_} ne '';
+ } # foreach
+
+ return $opts;
+} # _formatOpts
+
+sub _setComment ($) {
+ my ($comment) = @_;
+
+ return !$comment ? '-nc' : '-c "' . quotameta $comment . '"';
+} # _setComment
+
+sub vobname ($) {
+ my ($tag) = @_;
+
+=pod
+
+=head2 vobname ($tag)
+
+Given a vob tag, return the vob name by stripping of the VOBTAG_PREFIX properly
+such that you return just the unique vob name. This is tricky because Windows
+uses '\' as a VOBTAG_PREFIX. With '\' in there regex's like
+/$Clearcase::VOBTAG_PREFIX(.+)/ to capture the vob's name minus the
+VOBTAG_PREFIX fail because Perl evaluates this as just a single '\', which
+escapes the '(' of the '(.+)'!
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=over
+
+=item $tag
+
+Vob tag to convert
+
+=back
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=over
+
+=item $name
+
+The unique part of the vob name
+
+=back
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my $name = $tag;
+
+ # Special code because Windows $VOBTAG prefix (a \) is such a pain!
+ if (substr ($tag, 0, 1) eq '\\') {
+ $name = substr $tag, 1;
+ } elsif (substr ($tag, 0, 1) eq '/') {
+ if ($tag =~ /${Clearcase::VOBTAG_PREFIX}(.+)/) {
+ $name = $1;
+ } # if
+ } # if
+
+ return $name;
+} # vobname
+
+sub vobtag ($) {
+ my ($name) = @_;
+
+=pod
+
+=head2 vobtag ($name)
+
+Given a vob name, add the VOBTAG_PREFIX based on the current OS.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=over
+
+=item $name
+
+Vob name to convert
+
+=back
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=over
+
+=item $tag
+
+Vob tag
+
+=back
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ # If the $VOBTAG_PREFIX is already there then do nothing
+ if (substr ($name, 0, length $VOBTAG_PREFIX) eq $VOBTAG_PREFIX) {
+ return $name;
+ } else {
+ return "$VOBTAG_PREFIX$name";
+ } # if
+} # vobtag
+
+sub attributes ($$;%) {
+ # TODO: Need to handle other options too
+ my ($self, $type, $name, %newAttribs) = @_;
+
+=pod
+
+=head2 attributes ($type, $name)
+
+Get any attributes attached to the $type:$name
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=over
+
+=item $type
+
+Type of object to look for attributes. For example, activity, baseline, etc.
+
+=item $name
+
+Object name to look for attributes.
+
+=back
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=over
+
+=item %attributes
+
+Hash of attribute name/values
+
+=back
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my $cmd = "describe -fmt \"%Na\" $type:$name";
+
+ my ($status, @output) = $CC->execute ($cmd);
+
+ return if $status;
+
+ my %attributes;
+
+ if ($output[0]) {
+ # Parse output
+ my $attributes = $output[0];
+ my ($name, $value);
+
+ while ($attributes ne '') {
+ if ($attributes =~ /^=(\"*)(.*)/) {
+ if ($2 =~ /(.*?)$1(\s|$)(.*)/) {
+ $attributes{$name} = $1;
+ $attributes = $3;
+ } else {
+ $attributes{$name} = $2;
+ $attributes = '';
+ } # if
+ } elsif ($attributes =~ /^(\w+)=(.*)/) {
+ $name = $1;
+ $attributes = "=$2";
+ } else {
+ croak "Parsing error while parsing " . ref ($self) . " attributes";
+ } # if
+ } # while
+ } # if
+
+ # Set any %newAttribs
+ foreach (keys %newAttribs) {
+ # TODO: What about other options like -comment?
+ $cmd = "mkattr -replace -nc $_ \"";
+ $cmd .= quotemeta $newAttribs{$_};
+ $cmd .= "\" $type:$name";
+
+ $CC->execute ($cmd);
+
+ if ($CC->status) {
+ die "Unable to execute $cmd (Status: "
+ . $CC->status . ")\n"
+ . join ("\n", $CC->output);
+ } else {
+ $attributes{$_} = $newAttribs{$_};
+ } # if
+ } # foreach
+
+ return %attributes;
+} # attributes
+
+sub status () {
+ my ($self) = @_;
+
+=pod
+
+=head2 status ()
+
+Returns the status of the last executed command.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=over
+
+=item none
+
+=back
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=over
+
+=item $status
+
+Status of the command last executed.
+
+=back
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{status};
+} # status
+
+sub output () {
+ my ($self) = @_;
+
+=pod
+
+=head2 output ()
+
+Returns the output of the last executed command.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=over
+
+=item none
+
+=back
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=over
+
+=item @output or $output
+
+If called in a list context, returns @output, otherwise returns $output.
+
+=back
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ if (wantarray) {
+ return split /\n/, $self->{output};
+ } else {
+ return $self->{output};
+ } # if
+} # output
+
+# TODO: Should implement a pipe call that essentially does a cleartool command
+# to a pipe allowing the user to read from the pipe. This will help with such
+# cleartool command that may give back huge output or where the user wishes to
+# start processing the output as it comes instead of waiting until the cleartool
+# command is completely finished. Would like to do something like execute does
+# with cleartool running in the background but we need to handle the buffering
+# of output sending only whole lines.
+
+sub execute {
+ my ($self, $cmd) = @_;
+
+=pod
+
+=head2 execute ($cmd)
+
+Sends a command to the cleartool coprocess. If not running a cleartool coprocess
+is started and managed. The coprocess is implemented as a coprocess using IPC
+for communication that will exist until the object is destroyed. Stdin and
+stdout/stderr are therefore pipes and can be fed. The execute method feds the
+input pipe and returns status and output from the output pipe.
+
+Using execute can speed up execution of repeative cleartool invocations
+substantially.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=over
+
+=item $cmd
+
+Cleartool command to execute.
+
+=back
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=over
+
+=item $status
+
+Status of the command last executed.
+
+=item @output
+
+Array of output lines from the cleartool command execution.
+
+=back
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my ($status, @output);
+
+ # This seems to be how most people locate cleartool. On Windows (this
+ # includes Cygwin) we assume it's in our path. On Unix/Linux we assume it's
+ # installed under /opt/rational/clearcase/bin. This is needed in case we wish
+ # to use these Clearcase objects say in a web page where the server is often
+ # run as a plain user who does not have cleartool in their path.
+ my $cleartool;
+
+ if ($ARCH =~ /Win/ or $ARCH eq 'cygwin') {
+ $cleartool = 'cleartool';
+ } elsif (-x '/opt/rational/clearcase/bin/cleartool') {
+ $cleartool = '/opt/rational/clearcase/bin/cleartool';
+ } # if
+
+ # TODO: Need to catch SIGCHILD here in case the user does something like hit
+ # Ctrl-C. Such an action may interrupt the underlying cleartool process and
+ # kill it. But we would be unaware (i.e. $clearpid would still be set). So
+ # when SIGCHILD is caught we need to undef $clearpid.
+ if (!$clearpid) {
+ # Simple check to see if we can execute cleartool
+ @output = `$cleartool -ver 2>&1`;
+
+ return (-1, 'Clearcase not installed')
+ unless $? == 0;
+
+ $clearpid = open3 ($clearin, $clearout, $clearout, $cleartool, "-status");
+
+ return (-1, ('Clearcase not installed')) unless $clearpid;
+ } # if
+
+ # Execute command
+ print $clearin "$cmd\n";
+
+ # Now read output from $clearout and format the lines in to an array. Also
+ # capture the status code to return it.
+ while (my $line = <$clearout>) {
+ if ($line !~ /(.*)Command \d+ returned status (\d+)/sm) {
+ push @output, $line;
+ } else {
+ push @output, $1;
+ $status = $2;
+ last;
+ } # if
+ } # while
+
+ if (@output) {
+ chomp @output;
+ chop @output if $output[0] =~ /\r$/;
+ } # if
+
+ # We're getting extra blank lines at the bottom of @output. Not sure why
+ # but we need to remove it
+ pop @output
+ if @output and $output[$#output] eq '';
+
+ $self->{status} = $status;
+ $self->{output} = join "\n", @output;
+
+ return ($status, @output);
+} # execute
+
+sub new {
+ my ($class) = @_;
+
+=pod
+
+=head2 new ()
+
+Construct a new Clearcase object. Note there is already a default
+Clearcase object created named $cc. You should use that unless you
+have good reason to instantiate another Clearcase object.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Clearcase object
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ # Attributes
+ my (
+ $registry_host,
+ $version,
+ @regions,
+ );
+
+ my $self = bless {
+ registry_host => $registry_host,
+ version => $version,
+ verbose_level => 0,
+ vobtag_prefix => $VOBTAG_PREFIX,
+ viewtag_prefix => $VIEWTAG_PREFIX,
+ regions => \@regions,
+ }, $class;
+
+ # Get list of regions
+ my ($status, @output);
+
+ ($status, @regions) = $self->execute ('lsregion');
+
+ return $self
+ if $status;
+
+ # Get hostinfo attributes
+ ($status, @output) = $self->execute ('hostinfo -long');
+
+ return $self
+ if $status;
+
+ foreach (@output) {
+ if (/Client: (.*)/) {
+ $self->{client} = lc $1;
+ } elsif (/Product: (.*)/) {
+ $self->{version} = $1;
+ } elsif (/Operating system: (.*)/) {
+ $self->{os} = $1;
+ } elsif (/Hardware type: (.*)/) {
+ $self->{hardware_type} = $1;
+ } elsif (/Registry host: (.*)/) {
+ $self->{registry_host} = $1;
+ } elsif (/Registry region: (.*)/) {
+ $self->{region} = $1;
+ $self->{sitename} = $1;
+
+ if ($self->{region} =~ /(\S*)(NT|UNIX)$/) {
+ $self->{sitename} = $1;
+ } # if
+ } elsif (/License host: (.*)/) {
+ $self->{license_host} = $1;
+ } # if
+ } # foreach
+
+ return $self;
+} # new
+
+# Member access methods...
+
+sub client {
+ my ($self) = @_;
+
+=pod
+
+=head2 client
+
+Returns the client
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item client
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{client};
+} # client
+
+sub hardware_type {
+ my ($self) = @_;
+
+=pod
+
+=head2 hardware_type
+
+Returns the hardware_type
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item hardware_type
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{hardware_type};
+} # hardware_type
+
+sub license_host {
+ my ($self) = @_;
+
+=pod
+
+=head2 license_host
+
+Returns the license_host
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item license_host
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{license_host};
+} # license_host
+
+sub os {
+ my ($self) = @_;
+
+=pod
+
+=head2 os
+
+Returns the os
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item os
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{os};
+} # os
+
+sub region {
+ my ($self) = @_;
+
+=pod
+
+=head2 region
+
+Returns the region
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item region
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{region};
+} # region
+
+sub registry_host {
+ my ($self) = @_;
+
+=pod
+
+=head2 registry_host
+
+Returns the registry_host
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item client string
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{registry_host};
+} # registry_host
+
+sub sitename {
+ my ($self) = @_;
+
+=pod
+
+=head2 sitename
+
+Returns the sitename
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item sitename
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{sitename};
+} # sitename
+
+sub version {
+ my ($self) = @_;
+
+=pod
+
+=head2 version
+
+Returns the version
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item version
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{version};
+} # version
+
+sub regions {
+ my ($self) = @_;
+
+=pod
+
+=head2 regions
+
+Returns an array of regions in an array context or the number of
+regions in a scalar context
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item array of regions or number of regions
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ if (wantarray) {
+ my @returnArray = sort @{$self->{regions}};
+
+ return @returnArray;
+ } else {
+ return scalar @{$self->{regions}};
+ } # if
+} # regions
+
+sub pwv () {
+ my ($self) = @_;
+
+=pod
+
+=head2 pwv
+
+Returns the current working view or undef if not in a view
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Current working view or undef if none
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my ($status, @output) = $self->execute ('pwv -short');
+
+ return if $status;
+ return $output[0] eq '** NONE **' ? undef : $output[0];
+} # pwv
+
+sub name2oid ($;$) {
+ my ($self, $name, $vob) = @_;
+
+=pod
+
+=head2 name2oid
+
+Returns the oid for a given name
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item name
+
+The name to convert (unless filesystem object it should contain a type:)
+
+=item vob
+
+The vob the name belongs to
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item OID
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ if ($vob) {
+ $vob = '@' . vobtag $vob;
+ } else {
+ $vob = '';
+ } # if
+
+ my ($status, @output) = $self->execute ("dump $name$vob");
+
+ return if $status;
+
+ @output = grep { /^oid=/ } @output;
+
+ if ($output[0] =~ /oid=(\S+)\s+/) {
+ return $1;
+ } else {
+ return;
+ } # if
+} # name2oid
+
+sub oid2name ($$) {
+ my ($self, $oid, $vob) = @_;
+
+=pod
+
+=head2 oid2name
+
+Returns the object name for the given oid
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item oid
+
+The OID to convert
+
+=item vob
+
+The vob the OID belongs to
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item String representing the OID's textual name/value
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $vob = vobtag $vob
+ unless $vob =~ /^vobuuid:/;
+
+ my ($status, @output) = $self->execute (
+ "describe -fmt \"%n\" oid:$oid\@$vob"
+ );
+
+ return if $status;
+ return $output[0];
+} # oid2name
+
+sub verbose_level {
+ my ($self) = @_;
+
+=pod
+
+=head2 verbose_level
+
+Returns the verbose_level
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item verbose_level
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{verbose_level};
+} # verbose_level
+
+sub quiet {
+ my ($self) = @_;;
+
+=pod
+
+=head2 quiet
+
+Sets verbose_level to quiet
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $self->{verbose_level} = 0;
+
+ return;
+} # quiet
+
+sub noisy {
+ my ($self) = @_;
+
+=pod
+
+=head2 noisy
+
+Sets verbose_level to noisy
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $self->{verbose_level} = 1;
+
+ return;
+} # noisy
+
+$CC = Clearcase->new;
+
+1;
+
+=pod
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<IPC::Open3|IPC::Open3>
+
+=head2 ClearSCM Perl Modules
+
+=for html <p><a href="/php/cvs_man.php?file=lib/Display.pm">Display</a></p>
+
+=for html <p><a href="/php/cvs_man.php?file=lib/OSDep.pm">OSdep</a></p>
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this module
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2007, ClearSCM, Inc. All rights reserved.
+
+=cut
--- /dev/null
+=pod
+
+=head1 NAME $RCSfile: Element.pm,v $
+
+Object oriented interface to Clearcase Elements
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.18 $
+
+=item Created
+
+Thu Dec 29 12:07:59 PST 2005
+
+=item Modified
+
+$Date: 2011/11/16 19:46:13 $
+
+=back
+
+=head1 SYNOPSIS
+
+Provides access to information about Clearcase Elements.
+
+ my $element = new Clearcase::Element (pname => "element");
+
+ display "Element:\t" . $element->pname;
+ display "Version:\t" . $element->version;
+ display "Pred:\t\t" . $element->pred;
+
+ display "Activities:";
+
+ if (my %activities = $element->activities) {
+ display "\t\t$_: $activities{$_}" foreach (keys %activities);
+ } else {
+ display "\t\tNone";
+ } # if
+
+ display "Attributes:";
+
+ if (my %attributes = $element->attributes) {
+ display "\t\t$_=$attributes{$_}" foreach (keys %attributes);
+ } else {
+ display"\t\tNone";
+ } # if
+
+ display "Hyperlinks:";
+
+ if (my @hyperlinks = $element->hyperlinks) {
+ display "\t\t$_" foreach (@hyperlinks);
+ } else {
+ display "\t\tNone";
+ } # if
+
+ display "Comments:";
+
+ if ($element->comments) {
+ display "\t\t" . $element->comments;
+ } else {
+ display "\t\tNone";
+ } # if
+
+ display "Create_date:\t" . $element->create_date;
+ display "User:\t\t" . $element->user;
+ display "Group:\t\t" . $element->group;
+ display "User_mode:\t" . $element->user_mode;
+ display "Group_mode:\t" . $element->group_mode;
+ display "Other_mode:\t" . $element->other_mode;
+ display "Mode:\t\t" . $element->mode;
+
+ display "Labels:";
+
+ if (my @labels = $element->labels) {
+ display "\t\t$_" foreach (@labels);
+ } else {
+ display "\t\tNone";
+ } # if
+
+ display "Rule:\t\t" . $element->rule;
+ display "Xname:\t\t" . $element->xname;
+
+=head1 DESCRIPTION
+
+This module implements a Clearcase Element object.
+
+=head1 ROUTINES
+
+The following routines are exported:
+
+=cut
+
+package Clearcase::Element;
+
+use strict;
+use warnings;
+
+use lib '..';
+
+use Clearcase;
+
+sub collapseOverExtendedVersionPathname ($) {
+ my ($versionStr) = @_;
+
+=pod
+
+=head2 collapseOverExtendedVersionPathname
+
+This utility function will collapse an "over extended" version pathname. These
+over extended pathnames can occur when we are not operating in the UCM view
+from which the version was generated. Clearcase gives us enormous,technically
+correct but hard to read, view/vob extended path names. Here's an example
+(broken by lines for readability):
+
+ /vob/component/branch1@@/main/branch1_Integration/1/src/main/branch1_
+ /2/com/main/branch1_Integration/2/company/main/branch1_Integration/2/
+ ManagerPlatform/main/branch1_Integration/2/nma/main/
+ branch1_Integration/devbranch_17/1/common/main/devbranch_17/3/exception/
+ main/mainline/devbranch_r17/1/Exception.java/main/mainline/1
+
+We want this to read:
+
+ element: /vob/component/src/com/company/ManagerPlatform/nma/
+ common/exception/Exception.java
+ version: /main/mainline/1
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $versionStr
+
+This is the over extended version pathname
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item %element hash
+
+A hash containing the element's name and version string collapsed
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return
+ unless $versionStr;
+
+ $versionStr =~ s/\\/\//g;
+
+ my ($name, $version) = split /$Clearcase::SFX/, $versionStr;
+
+ my %element = (
+ extended_name => $versionStr,
+ name => $name,
+ version => $version,
+ );
+
+ return
+ unless $element{version};
+
+ while ($element{version} =~ s/.*?\/\d+\/(.*?)\///) {
+ $element{name} .= "/$1";
+ } # while
+
+ $element{version} = "/$element{version}"
+ if $element{version} !~ /^\//;
+
+ return %element;
+} # collapseOverExtendedVersionPathname
+
+sub new ($) {
+ my ($class, $pname) = @_;
+
+=pod
+
+=head2 new
+
+Construct a new Clearcase Element object.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item element name
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Clearcase Element object
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my $self = bless {
+ pname => $pname,
+ }, $class;
+
+ my ($version, $rule);
+
+ my ($status, @output) = $Clearcase::CC->execute ("ls -d $pname");
+
+ return $self
+ if $status;
+
+ # Sometimes ls -d puts out more than one line. Join them...
+ if ((join ' ', @output) =~ /^.*\@\@(\S+)\s+Rule: (.*)$/m) {
+ $version = $1;
+ $rule = $2;
+ } # if
+
+ $self->{rule} = $rule;
+ $self->{version} = $version;
+
+ return $self;
+} # new
+
+sub describe () {
+ my ($self) = @_;
+ # Get information that can only be gotten with describe -long. These fields
+ # lack a -fmt option.
+
+ my ($status, @output) = $Clearcase::CC->execute (
+ "describe -long $self->{pname}"
+ );
+
+ return
+ if $status != 0;
+
+ my $section;
+
+ foreach (@output) {
+ if (/Hyperlinks:/) {
+ $section = 'hyperlinks';
+ next;
+ } elsif (/Attached activities:/) {
+ $section = 'activities';
+ next;
+ } # if
+
+ if ($section) {
+ if ($section eq 'activities') {
+ if (/activity:(.*)\s+\"(.*)\"/) {
+ ${$self->{activities}}{$1} = $2;
+ } # if
+ } elsif ($section eq "hyperlinks") {
+ if (/\s+(.*)/) {
+ push @{$self->{hyperlinks}}, $1;
+ } # if
+ } # if
+
+ next;
+ } # if
+
+ if (/User : \S+\s*: (.*)/) {
+ $self->{user_mode} = $1;
+ } elsif (/Group: \S+\s*: (.*)/) {
+ $self->{group_mode} = $1;
+ } elsif (/Other:\s+: (.*)/) {
+ $self->{other_mode} = $1;
+ } # if
+ } # foreach
+
+ # Change modes to numeric
+ $self->{mode} = 0;
+
+ $self->{mode} += 400 if $self->{user_mode} =~ /r/;
+ $self->{mode} += 200 if $self->{user_mode} =~ /w/;
+ $self->{mode} += 100 if $self->{user_mode} =~ /x/;
+ $self->{mode} += 40 if $self->{group_mode} =~ /r/;
+ $self->{mode} += 20 if $self->{group_mode} =~ /w/;
+ $self->{mode} += 10 if $self->{group_mode} =~ /x/;
+ $self->{mode} += 4 if $self->{other_mode} =~ /r/;
+ $self->{mode} += 2 if $self->{other_mode} =~ /w/;
+ $self->{mode} += 1 if $self->{other_mode} =~ /x/;
+
+ return;
+} # describe
+
+sub activities () {
+ my ($self) = @_;
+
+=pod
+
+=head2 activities
+
+Returns a hash of activity name/value pairs
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Hash of activity name/value pairs
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $self->describe
+ unless $self->{activities};
+
+ return $self->{activities} ? %{$self->{activities}} : ();
+} # activities
+
+sub attributes () {
+ my ($self) = @_;
+
+=pod
+
+=head2 attributes
+
+Returns a hash of attribute name/value pairs
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Hash of attribute name/value pairs
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $self->updateElementInfo
+ unless $self->{attributes};
+
+ return %{$self->{attributes}};
+} # attributes
+
+sub comments () {
+ my ($self) = @_;
+
+=pod
+
+=head2 comments
+
+Returns the comments associated with the current version element.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item comment
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $self->updateElementInfo
+ unless $self->{comments};
+
+ return $self->{comments};
+} # comments
+
+sub create_date () {
+ my ($self) = @_;
+
+=pod
+
+=head2 create_date
+
+Returns the date of creation of the element.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item create date
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $self->updateElementInfo
+ unless $self->{create_date};
+
+ return $self->{create_date};
+} # create_date
+
+sub group () {
+ my ($self) = @_;
+
+=pod
+
+=head2 group
+
+Returns the group of the element.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item group
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $self->updateElementInfo
+ unless $self->{group};
+
+ return $self->{group};
+} # group
+
+sub group_mode () {
+ my ($self) = @_;
+
+=pod
+
+=head2 group_mode
+
+Returns the group mode of the element
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item group mode
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $self->describe
+ unless $self->{group_mode};
+
+ return $self->{group_mode};
+} # group_mode
+
+sub hyperlinks () {
+ my ($self) = @_;
+
+=pod
+
+=head2 hyperlinks
+
+Returns a hash of hyperlink name/value pairs
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Hash of hyperlink name/value pairs
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $self->describe
+ unless $self->{hyperlinks};
+
+ return @{$self->{hyperlinks}}
+} # hyperlinks
+
+sub labels () {
+ my ($self) = @_;
+
+=pod
+
+=head2 labels
+
+Returns an array of labels
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Array of labels
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $self->updateElementInfo
+ unless $self->{labels};
+
+ return @{$self->{labels}};
+} # labels
+
+sub mode () {
+ my ($self) = @_;
+
+=pod
+
+=head2 mode
+
+Returns the numeric mode representing the element's access mode
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Array of activities
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $self->describe
+ unless $self->{mode};
+
+ return $self->{mode};
+} # mode
+
+sub other_mode () {
+ my ($self) = @_;
+
+=pod
+
+=head2 other_mode
+
+Returns the mode for other for the element.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item A string repesenting the other mode
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $self->describe
+ unless $self->{other_mode};
+
+ return $self->{other_mode};
+} # other_mode
+
+sub pname () {
+ my ($self) = @_;
+
+=pod
+
+=head2 pname
+
+Returns the pname of the element.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item pname
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{pname};
+} # pname
+
+sub pred () {
+ my ($self) = @_;
+
+=pod
+
+=head2 pred
+
+Returns the predecessor version of this element
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Predecessor version
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $self->updateElementInfo
+ unless $self->{pred};
+
+ return $self->{pred};
+} # pred
+
+sub rule () {
+ my ($self) = @_;
+
+=pod
+
+=head2 rule
+
+Returns the config spec rule that selected this element's version.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item rule
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{rule};
+} # rule
+
+sub type () {
+ my ($self) = @_;
+
+=pod
+
+=head2 type
+
+Returns the element's type
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item element type
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $self->updateElementInfo
+ unless $self->{type};
+
+ return $self->{type};
+} # type
+
+sub objkind () {
+ my ($self) = @_;
+
+=pod
+
+=head2 objkind
+
+Returns the element's object kind
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item element's object kind
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $self->updateElementInfo
+ unless $self->{objkind};
+
+ return $self->{objkind};
+} # objkind
+
+sub oid ($) {
+ my ($version) = @_;
+
+=pod
+
+=head2 oid
+
+Returns the element's OID
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item element's OID
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $version .= $Clearcase::SFX
+ unless $version =~ /$Clearcase::SFX$/;
+
+ my ($status, @output) = $Clearcase::CC->execute ('dump "' . $version . '"');
+
+ return
+ unless $status == 0;
+
+ @output = grep {/^oid=/} @output;
+
+ if ($output[0] =~ /oid=(.+?)\s+/) {
+ return $1;
+ } # if
+} # oid
+
+sub user () {
+ my ($self) = @_;
+
+=pod
+
+=head2 user
+
+Returns the username of the owner of this element.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item user name
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $self->updateElementInfo
+ unless $self->{user};
+
+ return $self->{user};
+} # user
+
+sub user_mode () {
+ my ($self) = @_;
+
+=pod
+
+=head2 user_mode
+
+Returns the mode for the user for the element.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item A string repesenting the other mode
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $self->describe
+ unless $self->{user_mode};
+
+ return $self->{user_mode};
+} # user_mode
+
+sub version () {
+ my ($self) = @_;
+
+=pod
+
+=head2 version
+
+Returns this element's version
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item version
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{version};
+} # version
+
+sub xname () {
+ my ($self) = @_;
+
+=pod
+
+=head2 xname
+
+Returns the view extended path name (xname) of an element version.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item xname
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $self->updateElementInfo
+ unless $self->{xname};
+
+ return $self->{xname};
+} # xname
+
+sub mkelem (;$) {
+ my ($self, $comment) = @_;
+
+=pod
+
+=head2 mkelem
+
+Returns creates a new element
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item Comment
+
+Creation comment. Default -nc.
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $status
+
+Status from cleartool
+
+=item @output
+
+Ouput from cleartool
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $comment = Clearcase::_setComment $comment;
+
+ return $Clearcase::CC->execute ("mkelem $comment $self->{pname}");
+} # mkelem
+
+sub checkout (;$) {
+ my ($self, $comment) = @_;
+
+=pod
+
+=head2 checkout
+
+Checks out the element
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item comment
+
+Checkout comment. Default -nc.
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $status
+
+Status from cleartool
+
+=item @output
+
+Ouput from cleartool
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $comment = Clearcase::_setComment $comment;
+
+ return $Clearcase::CC->execute ("checkout $comment $self->{pname}");
+} # checkout
+
+sub checkin (;$) {
+ my ($self, $comment) = @_;
+
+=pod
+
+=head2 checkin
+
+Checks in the element
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item comment
+
+Check in comment. Default -nc.
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $status
+
+Status from cleartool
+
+=item @output
+
+Ouput from cleartool
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $comment = Clearcase::_setComment $comment;
+
+ return $Clearcase::CC->execute ("checkin $comment $self->{pname}");
+} # checkout
+
+sub updateElementInfo () {
+ my ($self) = @_;
+
+ # Get all information that can be gotten using -fmt
+ my $fmt = 'Attributes:%aEndAttributes:'
+ . 'Comment:%cEndComment:'
+ . 'Create_date:%dEndCreate_date:'
+ . 'Group:%[group]pEndGroup:'
+ . 'Labels:%NlEndLabels:'
+ . 'Pred:%PSnEndPred:'
+ . 'Type:%[type]pEndType:'
+ . 'ObjectKind:%mEndObjectKind:'
+ . 'User:%[owner]pEndUser:'
+ . 'Xname:%XnEndXname:';
+
+ my ($status, @output) =
+ $Clearcase::CC->execute ("describe -fmt \"$fmt\" $self->{pname}");
+
+ return
+ unless $status == 0;
+
+ # We need to make sure that fields are filled in or empty because we are using
+ # undef as an indication that we have not called updateElementInfo yet.
+ $self->{attributes} =
+ $self->{labels} = ();
+
+ $self->{comments} =
+ $self->{create_date} =
+ $self->{group} =
+ $self->{pred} =
+ $self->{type} =
+ $self->{objkind} =
+ $self->{user} =
+ $self->{xname} = '';
+
+ foreach (@output) {
+ # This output is wrapped with parenthesis...
+ if (/Attributes:\((.*)\)EndAttributes:/) {
+ my @attributes = split ", ", $1;
+ my %attributes;
+
+ foreach (@attributes) {
+ if (/(\w+)=(\w+)/) {
+ $attributes{$1}=$2;
+ } # if
+ } # foreach
+
+ $self->{attributes} = %attributes ? \%attributes : ();
+ } # if
+
+ if (/Comments:(.*)EndComments:/) {
+ $self->{comments} = $1;
+ } # if
+
+ if (/Create_date:(.*)EndCreate_date:/) {
+ $self->{create_date} = $1;
+ } # if
+
+ if (/Group:(.*)EndGroup:/) {
+ $self->{group} = $1;
+ } # if
+
+ if (/Labels:(.*)EndLabels:/) {
+ my @labels = split " ", $1;
+ $self->{labels} = @labels ? \@labels : ();
+ } # if
+
+ if (/Pred:(.*)EndPred:/) {
+ $self->{pred} = $1;
+ } # if
+
+ if (/Type:(.*)EndType:/) {
+ $self->{type} = $1;
+ } # if
+
+ if (/ObjectKind:(.*)EndObjectKind:/) {
+ $self->{objkind} = $1;
+ } # if
+
+ if (/User:(.*)EndUser:/) {
+ $self->{user} = $1;
+ } # if
+
+ if (/Xname:(.*)EndXname:/) {
+ $self->{xname} = $1;
+ } # if
+ } # foreach
+
+ return;
+} # updateElementInfo
+
+1;
+
+=head2 DEPENDENCIES
+
+=head3 ClearSCM Perl Modules
+
+=for html <p><a href="/php/cvs_man.php?file=lib/Clearcase.pm">Clearcase</a></p>
+
+=head2 INCOMPATABILITIES
+
+None
+
+=head2 BUGS AND LIMITATIONS
+
+There are no known bugs in this module.
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head2 LICENSE AND COPYRIGHT
+
+Copyright (c) 2007, ClearSCM, Inc. All rights reserved.
+
+=cut
--- /dev/null
+=pod
+
+=head1 NAME $RCSfile: Server.pm,v $
+
+Object oriented interface to a Clearcase Server
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.2 $
+
+=item Created
+
+Sat Dec 18 09:51:15 EST 2010
+
+=item Modified
+
+$Date: 2011/01/02 04:59:36 $
+
+=back
+
+=head2 SYNOPSIS
+
+Provides access to information about a Clearcase Server.
+=head2 DESCRIPTION
+
+This module implements an object oriented interface to a Clearcase
+Server.
+
+=head2 ROUTINES
+
+The following routines are exported:
+
+=cut
+
+package Clearcase::Server;
+
+use strict;
+use warnings;
+
+use Clearcase;
+
+=pod
+
+=head2 new (tag)
+
+Construct a new Clearcase View object. Note that not all members are
+initially populated because doing so would be time consuming. Such
+member variables will be expanded when accessed.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item tag
+
+View tag to be instantiated. You can use either an object oriented call
+(i.e. my $view = new Clearcase::View (tag => 'my_new_view')) or the
+normal call (i.e. my $vob = new Clearcase::View ('my_new_view')). You
+can also instantiate a new view by supplying a tag and then later
+calling the create method.
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Clearcase View object
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+sub new ($;$) {
+ my ($class, $name) = @_;
+
+ my $self = bless { name => $name }, $class;
+
+ return $self;
+} # new
+
+sub name () {
+ my ($self) = @_;
+
+ return $self->{name};
+} # name
+
+sub ccVer () {
+ my ($self) = @_;
+
+ return $self->{ccVer};
+} # ccVer
+
+sub osVer () {
+ my ($self) = @_;
+
+ return $self->{osVer};
+} # osVer
+
+sub hardware () {
+ my ($self) = @_;
+
+ return $self->{hardware};
+} # hardware
+
+sub licenseHost () {
+ my ($self) = @_;
+
+ return $self->{licenseHost};
+} # licenseHost
+
+sub registryHost () {
+ my ($self) = @_;
+
+ return $self->{registryHost};
+} # registryHost
+
+sub registryRegion () {
+ my ($self) = @_;
+
+ return $self->{registryRegion};
+} # registryRegion
+
+sub mvfsBlocksPerDirectory () {
+ my ($self) = @_;
+
+ return $self->{mvfsBlocksPerDirectory};
+} # mvfsBlocksPerDirectory
+
+sub mvfsCleartextMnodes () {
+ my ($self) = @_;
+
+ return $self->{mvfsCleartextMnodes};
+} # mvfsCleartextMnodes
+
+sub mvfsDirectoryNames () {
+ my ($self) = @_;
+
+ return $self->{mvfsDirectoryNames};
+} # mvfsDirectoryNames
+
+sub mvfsFileNames () {
+ my ($self) = @_;
+
+ return $self->{mvfsFileNames};
+} # mvfsFileNames
+
+sub mvfsFreeMnodes () {
+ my ($self) = @_;
+
+ return $self->{mvfsFreeMnodes};
+} # mvfsFreeMnodes
+
+sub mvfsInitialMnodeTableSize () {
+ my ($self) = @_;
+
+ return $self->{mvfsInitialMnodeTableSize};
+} # mvfsInitialMnodeTableSize
+
+sub mvfsMinCleartextMnodes () {
+ my ($self) = @_;
+
+ return $self->{mvfsMinCleartextMnodes};
+} # mvfsMinCleartextMnodes
+
+sub mvfsMinFreeMnodes () {
+ my ($self) = @_;
+
+ return $self->{mvfsMinFreeMnodes};
+} # mvfsMinFreeMnodes
+
+sub mvfsNamesNotFound () {
+ my ($self) = @_;
+
+ return $self->{mvfsNamesNotFound};
+} # mvfsNamesNotFound
+
+sub mvfsRPCHandles () {
+ my ($self) = @_;
+
+ return $self->{mvfsRPCHandles};
+} # mvfsRPCHandles
+
+sub interopRegion () {
+ my ($self) = @_;
+
+ return $self->{interopRegion};
+} # interopRegion
+
+sub scalingFactor () {
+ my ($self) = @_;
+
+ return $self->{scalingFactor};
+} # scalingFactor
+
+sub cleartextIdleLifetime () {
+ my ($self) = @_;
+
+ return $self->{cleartextIdleLifetime};
+} # cleartextIdleLifetime
+
+sub vobHashTableSize () {
+ my ($self) = @_;
+
+ return $self->{vobHashTableSize};
+} # vobHashTableSize
+
+sub cleartextHashTableSize () {
+ my ($self) = @_;
+
+ return $self->{cleartextHashTableSize};
+} # cleartextHashTableSize
+
+sub dncHashTableSize () {
+ my ($self) = @_;
+
+ return $self->{dncHashTableSize};
+} # dncHashTableSize
+
+sub threadHashTableSize () {
+ my ($self) = @_;
+
+ return $self->{threadHashTableSize};
+} # threadHashTableSize
+
+sub processHashTableSize () {
+ my ($self) = @_;
+
+ return $self->{processHashTableSize};
+} # processHashTableSize
+
+1;
+
+=pod
+
+=head2 DEPENDENCIES
+
+=for html <p><a href="/php/cvs_man.php?file=lib/Clearcase.pm">Clearcase</a></p>
+
+=head2 INCOMPATABILITIES
+
+None
+
+=head2 BUGS AND LIMITATIONS
+
+There are no known bugs in this module.
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head2 LICENSE AND COPYRIGHT
+
+Copyright (c) 2007, ClearSCM, Inc. All rights reserved.
+
+=cut
--- /dev/null
+=pod
+
+=head1 NAME $RCSfile: UCM.pm,v $
+
+Object oriented interface to UCM Streams
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.2 $
+
+=item Created
+
+Fri May 14 18:16:16 PDT 2010
+
+=item Modified
+
+$Date: 2011/11/16 19:46:13 $
+
+=back
+
+=head1 SYNOPSIS
+
+Provides access to information about Clearcase Elements.
+
+ my $stream= new Clearcase::UCM::Stream ($name, $pvob);
+
+=head1 DESCRIPTION
+
+This module implements a UCM Stream object
+
+=head1 ROUTINES
+
+The following routines are exported:
+
+=cut
+
+package Clearcase::UCM;
+
+use strict;
+use warnings;
+
+use Clearcase;
+use Clearcase::Vob;
+use Clearcase::Vobs;
+
+sub new ($) {
+ my ($class, $stream) = @_;
+
+=pod
+
+=head2 new
+
+Construct a new Clearcase Stream object.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item stream name
+
+Name of stream
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Clearcase Stream object
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return bless {
+ }, $class; # bless
+} # new
+
+sub pvobs () {
+ my ($self) = @_;
+
+=pod
+
+=head2 pvob
+
+Returns the pvob of the stream
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item stream's pvob
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my @pvobs;
+
+ my $VOBs = Clearcase::Vobs->new;
+
+ foreach my $vobtag ($VOBs->vobs) {
+ my $VOB = Clearcase::Vob->new ("$Clearcase::VOBTAG_PREFIX$vobtag");
+ my $attr = $VOB->vob_registry_attributes;
+
+ if ($attr and $attr =~ /ucmvob/) {
+ push @pvobs, $vobtag;
+ } # if
+ } # foreach
+
+ return @pvobs;
+} # pvobs
+
+1;
+
+=head1 DEPENDENCIES
+
+=head2 ClearSCM Perl Modules
+
+=for html <p><a href="/php/cvs_man.php?file=lib/Clearcase.pm">Clearcase</a></p>
+
+=head1 INCOMPATABILITIES
+
+None
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this module.
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2007, ClearSCM, Inc. All rights reserved.
+
+=cut
--- /dev/null
+=pod
+
+=head1 NAME $RCSfile: Activity.pm,v $
+
+Object oriented interface to UCM Activities
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.10 $
+
+=item Created
+
+Fri May 14 18:16:16 PDT 2010
+
+=item Modified
+
+$Date: 2011/11/15 01:56:40 $
+
+=back
+
+=head1 SYNOPSIS
+
+Provides access to information about Clearcase Activites.
+
+ my $activity = new Clearcase::UCM::Activity ($name, $pvob);
+
+ my @changeset = $activity->changeset;
+
+ foreach my $element (@changeset) {
+ display "Element name: " . $element->pname;
+ display "Element verison: " . $element->version;
+ } # foreach
+
+=head1 DESCRIPTION
+
+This module implements a UCM Activity object
+
+=head1 ROUTINES
+
+The following routines are exported:
+
+=cut
+
+package Clearcase::UCM::Activity;
+
+use strict;
+use warnings;
+
+use lib '../..';
+
+use Clearcase;
+use Clearcase::Element;
+
+# We should really inherit these from a more generic super class...
+sub _processOpts (%) {
+ my ($self, %opts) = @_;
+
+ my $opts;
+
+ foreach (keys %opts) {
+ if ($_ eq 'cq' or $_ eq 'cqe' or $_ eq 'force' or $_ eq 'nc') {
+ $opts .= "-$_ ";
+ } elsif ($_ eq 'c' or $_ eq 'cfile') {
+ $opts .= "-$_ $opts{$_}";
+ } # if
+ } # foreach
+
+ return $opts;
+} # _processOpts
+
+sub new ($$) {
+ my ($class, $activity, $pvob) = @_;
+
+=pod
+
+=head2 new
+
+Construct a new Clearcase Activity object.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item activity name
+
+Name of activity
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Clearcase Activity object
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my $self = bless {
+ name => $activity,
+ pvob => Clearcase::vobtag ($pvob),
+ type => $activity =~ /^(deliver|rebase)./ ? 'integration' : 'regular',
+ }, $class; # bless
+
+ return $self;
+} # new
+
+sub name () {
+ my ($self) = @_;
+
+=pod
+
+=head2 name
+
+Returns the name of the activity
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item activity's name
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{name};
+} # name
+
+sub pvob () {
+ my ($self) = @_;
+
+=pod
+
+=head2 pvob
+
+Returns the pvob of the activity
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item activity's pvob
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{pvob};
+} # pvob
+
+sub type () {
+ my ($self) = @_;
+
+=pod
+
+=head2 type
+
+Returns the type of the activity
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item activity's type
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{type};
+} # type
+
+sub contrib_acts () {
+ my ($self) = @_;
+
+=pod
+
+=head2 contrib_acts
+
+Returns the contributing activities
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Array of contributing activities
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $self->updateActivityInfo () unless $self->{contrib_acts};
+
+ return $self->{contrib_acts};
+} # crm_record
+
+sub crm_record_id () {
+ my ($self) = @_;
+
+=pod
+
+=head2 crm_record_id
+
+Returns the crm_record_id of the activity
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item activity's crm_record_id
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $self->updateActivityInfo () unless $self->{crm_record_id};
+
+ return $self->{crm_record_id};
+} # crm_record_id
+
+sub crm_record_type () {
+ my ($self) = @_;
+
+=pod
+
+=head2 crm_record_type
+
+Returns the crm_record_type of the activity
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item activity's crm_record_type
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $self->updateActivityInfo () unless $self->{crm_record_type};
+
+ return $self->{crm_record_type};
+} # crm_record_type
+
+sub crm_state () {
+ my ($self) = @_;
+
+=pod
+
+=head2 crm_state
+
+Returns the crm_state of the activity
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item activity's crm_state
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $self->updateActivityInfo () unless $self->{crm_state};
+
+ return $self->{crm_state};
+} # crm_state
+
+sub headline () {
+ my ($self) = @_;
+
+=pod
+
+=head2 headline
+
+Returns the headline of the activity
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item activity's headline
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $self->updateActivityInfo () unless $self->{headline};
+
+ return $self->{headline};
+} # headline
+
+sub name_resolver_view () {
+ my ($self) = @_;
+
+=pod
+
+=head2 name_resolver_view
+
+Returns the name_resolver_view of the activity
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item activity's name_resolver_view
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $self->updateActivityInfo () unless $self->{name_resolver_view};
+
+ return $self->{name_resolver_view};
+} # name_resolver_view
+
+sub stream () {
+ my ($self) = @_;
+
+=pod
+
+=head2 stream
+
+Returns the stream of the activity
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item activity's stream
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $self->updateActivityInfo () unless $self->{stream};
+
+ return $self->{stream};
+} # stream
+
+sub changeset (;$) {
+ my ($self, $recalc) = @_;
+
+=pod
+
+=head2 changeset
+
+Returns the changeset of the activity
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item An array containing Clearcase::Element objects.
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ if ($self->{changeset}) {
+ return $self->{changeset} unless ($recalc);
+ } # if
+
+ my $pvob = Clearcase::vobtag $self->{pvob};
+
+ my $cmd = "lsact -fmt \"%[versions]CQp\" $self->{name}\@$pvob";
+
+ my ($status, @output) = $Clearcase::CC->execute ($cmd);
+
+ return ($status, @output)
+ if $status;
+
+ # Need to split up change set. It's presented to us as quoted and space
+ # separated however the change set elements themselves can have spaces in
+ # them! e.g.:
+ #
+ # "/vob/foo/file name with spaces@@/main/1", "/vob/foo/file name2@@/main/2"
+ #
+ # So we'll split on '", ""'! Note that this will leave us with the first
+ # element with a leading '"' and the last element with a trailing '"' which
+ # we will have to handle.
+ #
+ # Additionally we will call collapseOverExtendedViewPathname to normalize
+ # the over extended pathnames to element hashes.
+ my (@changeset);
+
+ @output = split /\", \"/, $output[0]
+ if $output[0];
+
+ foreach (@output) {
+ # Skip any cleartool warnings. We are getting warnings of the form:
+ # "A version in the change set of activity "63332.4" is currently
+ # unavailable". Probably some sort of subtle corruption that we can ignore.
+ # (It should be fixed but we aren't going to be doing that here!)
+ next if /cleartool: Warning/;
+
+ # Strip any remaining '"'s
+ s/^\"//; s/\"$//;
+
+ my %element = Clearcase::Element::collapseOverExtendedVersionPathname $_;
+ my $element = Clearcase::Element->new ($element{name});
+
+ # Sometimes $element{name} refers to a long path name we can't easily see
+ # in our current view. In such cases the above Clearcase::Element->new will
+ # return us an element where the version is missing. Since we already have
+ # the version information we will replace it here.
+ #
+ # The following may look odd since we use similar names against different
+ # Perl variables. $element->{version} means look into the $element object
+ # returned from new above at the member version. $element{version} says
+ # refer to the %element hash defined above for the version key. And finally
+ # $element->version says call the method version of the element object.
+ # So we are saying, if the version member of the element object is not
+ # defined (i.e. $element->version) then set it (i.e. $element->{version})
+ # by using the value of the hash %element with the key version.
+ $element->{version} = $element{version}
+ unless $element->version;
+
+ # Additionally we will set into the $element object the extended name. This
+ # is the long pathname that we need to use from our current context to be
+ # able to access the element.
+ #$element->setExtendedName ($_);
+
+ push @changeset, $element;
+ } # foreach
+
+ $self->{changeset} = \@changeset;
+
+ return @changeset;
+} # changeset
+
+sub create ($$$;$) {
+ my ($self, $stream, $pvob, $headline, $opts) = @_;
+
+=pod
+
+=head2 create
+
+Creates a new UCM Activity
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item UCM Stream (required)
+
+UCM stream this activities is to be created on
+
+=item PVOB (Required)
+
+Project Vob
+
+=item headline
+
+Headline to associate with this activity
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $status
+
+Status from cleartool
+
+=item @output
+
+Ouput from cleartool
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ # Fill in members
+ $self->{stream} = $stream;
+ $self->{pvob} = $pvob;
+
+ # TODO: Should quote $headline to protect from special characters
+ $self->{headline} = $headline;
+
+ # Fill in opts
+ $opts ||= '';
+ $opts .= " -headline '$headline'"
+ if $headline;
+
+ # TODO: This should call the exists function
+ # Return the stream name if the stream already exists
+ my ($status, @output) =
+ $Clearcase::CC->execute ('lsact -short ' . $self->{name});
+
+ return ($status, @output)
+ unless $status;
+
+ # Need to create the stream
+ return $Clearcase::CC->execute
+ ("mkactivity $opts -in " . $stream .
+ "\@" . $pvob .
+ ' ' . $self->{name});
+} # create
+
+sub remove () {
+ my ($self) = @_;
+
+=pod
+
+=head2 remove
+
+Removes UCM Activity
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $status
+
+Status from cleartool
+
+=item @output
+
+Ouput from cleartool
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $Clearcase::CC->execute
+ ('rmactivity -f ' . $self->{name} . "\@" . $self->{pvob});
+} # remove
+
+sub attributes (;%) {
+ my ($self, %newAttribs) = @_;
+
+=pod
+
+=head2 attributes
+
+Returns a hash of the attributes associated with an activity
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item %attributes
+
+Hash of attributes for this activity
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->Clearcase::attributes (
+ 'activity',
+ "$self->{name}\@" . Clearcase::vobtag ($self->{pvob}),
+ %newAttribs,
+ );
+} # attributes
+
+sub updateActivityInfo () {
+ my ($self) = @_;
+
+ # Get all information that can be gotten using -fmt
+ my $fmt .= '%[crm_record_id]p==';
+ $fmt .= '%[crm_record_type]p==';
+ $fmt .= '%[crm_state]p==';
+ $fmt .= '%[headline]p==';
+ $fmt .= '%[name_resolver_view]p==';
+ $fmt .= '%[stream]Xp==';
+ $fmt .= '%[view]p';
+
+ if ($self->type eq 'integration') {
+ $fmt = '%[contrib_acts]CXp==';
+ } # if
+
+ $Clearcase::CC->execute (
+ "lsactivity -fmt \"$fmt\" $self->{name}@" . Clearcase::vobtag ($self->{pvob})
+ );
+
+ # Assuming this activity is an empty shell of an object that the user may
+ # possibly use the create method on, return our blessings...
+ return if $Clearcase::CC->status;
+
+ # We need to make sure that fields are filled in or empty because we are using
+ # undef as an indication that we have not called updateActivityInfo yet.
+ my @fields = split '==', $Clearcase::CC->output;
+
+ $self->{crm_record_id} = $fields[0];
+ $self->{crm_record_type} = $fields[1];
+ $self->{crm_state} = $fields[2];
+ $self->{headline} = $fields[3];
+ $self->{name_resolver_view} = $fields[4];
+ $self->{stream} = $fields[5];
+ $self->{view} = $fields[6];
+
+ $self->{contrib_acts} = ();
+
+ if ($self->type eq 'integration') {
+ foreach (split ', ', $fields[7]) {
+ push @{$self->{contrib_acts}}, Clearcase::UCM::Activity->new ($_);
+ } # foreach
+ } # if
+
+ return;
+} # updateActivityInfo
+
+1;
+
+=head1 DEPENDENCIES
+
+=head2 ClearSCM Perl Modules
+
+=for html <p><a href="/php/cvs_man.php?file=lib/Clearcase.pm">Clearcase</a></p>
+
+=head1 INCOMPATABILITIES
+
+None
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this module.
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2007, ClearSCM, Inc. All rights reserved.
+
+=cut
--- /dev/null
+=pod
+
+=head1 NAME $RCSfile: Baseline.pm,v $
+
+Object oriented interface to UCM Streams
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.4 $
+
+=item Created
+
+Fri May 14 18:16:16 PDT 2010
+
+=item Modified
+
+$Date: 2011/11/15 01:59:07 $
+
+=back
+
+=head1 SYNOPSIS
+
+Provides access to information about Clearcase Elements.
+
+ my $stream= new Clearcase::UCM::Stream ($name, $pvob);
+
+=head1 DESCRIPTION
+
+This module implements a UCM Stream object
+
+=head1 ROUTINES
+
+The following routines are exported:
+
+=cut
+
+package Clearcase::UCM::Baseline;
+
+use strict;
+use warnings;
+
+use Carp;
+
+use lib '../..';
+
+use Clearcase;
+use Clearcase::Element;
+use Clearcase::UCM::Activity;
+
+sub _processOpts (%) {
+ my ($self, %opts) = @_;
+
+ my $opts;
+
+ foreach (keys %opts) {
+ if ($_ eq 'cq' or $_ eq 'cqe' or $_ eq 'force' or $_ eq 'nc') {
+ $opts .= "-$_ ";
+ } elsif ($_ eq 'c' or $_ eq 'cfile') {
+ $opts .= "-$_ $opts{$_}";
+ } # if
+ } # foreach
+
+
+ return $opts;
+} # _processOpts
+
+sub new ($$) {
+ my ($class, $baseline, $pvob) = @_;
+
+=pod
+
+=head2 new
+
+Construct a new Clearcase Stream object.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item stream name
+
+Name of stream
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Clearcase Stream object
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my $self = bless {
+ name => $baseline,
+ pvob => Clearcase::vobtag $pvob,
+ }, $class; # bless
+
+ return $self;
+} # new
+
+sub name () {
+ my ($self) = @_;
+
+=pod
+
+=head2 name
+
+Returns the name of the stream
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item stream's name
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{name};
+} # name
+
+sub pvob () {
+ my ($self) = @_;
+
+=pod
+
+=head2 pvob
+
+Returns the pvob of the stream
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item stream's pvob
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{pvob};
+} # pvob
+
+sub create ($$;$$) {
+ my ($self, $project, $pvob, $baseline, $opts) = @_;
+
+=pod
+
+=head2 create
+
+Creates a new UCM Stream Object
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item UCM Project (required)
+
+UCM Project this stream belongs to
+
+=item PVOB (Required)
+
+Project Vob
+
+=item baseline
+
+Baseline to set this stream to
+
+=item opts
+
+Options: Additional options to use (e.g. -readonly)
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $status
+
+Status from cleartool
+
+=item @output
+
+Ouput from cleartool
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ # Fill in object members
+ $self->{project} = $project;
+ $self->{pvob} = $pvob;
+
+ # Fill in opts
+ $opts ||= '';
+ $opts .= " -baseline $baseline"
+ if $baseline;
+
+ $self->{readonly} = $opts =~ /-readonly/;
+
+ # TODO: This should call the exists function
+ # Return the stream name if the stream already exists
+ my ($status, @output) =
+ $Clearcase::CC->execute ('lsstream -short ' . $self->{name});
+
+ return ($status, @output)
+ unless $status;
+
+ # Need to create the stream
+ return $Clearcase::CC->execute
+ ("mkstream $opts -in " . $self->{project} .
+ "\@" . $self->{pvob} .
+ ' ' . $self->{name});
+} # create
+
+sub remove (\%) {
+ my ($self, %opts) = @_;
+
+=pod
+
+=head2 remove
+
+Removes UCM Baseline
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=item %opts
+
+Options: Additional options to use (e.g. -c, -force, etc.)
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item nothing
+
+Remember to check status method for error, and/or output method for output.
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my $opts = $self->_processOpts (%opts);
+
+ my $pvob = Clearcase::vobtag ($self->{pvob});
+
+ my ($status, @output) = $Clearcase::CC->execute
+ ("rmbl $opts " . $self->{name} . '@' . $pvob);
+
+ return;
+} # remove
+
+sub attributes () {
+ my ($self) = @_;
+
+=pod
+
+=head2 attributes
+
+Returns a hash of the attributes associated with a baseline
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item %attributes
+
+Hash of attributes for this baseline
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->Clearcase::attributes (
+ 'baseline',
+ "$self->{name}\@" . Clearcase::vobtag ($self->{pvob})
+ );
+} # attributes
+
+sub diff ($;$$) {
+ my ($self, $type, $baseline, %opts) = @_;
+
+=pod
+
+=head2 diff
+
+Returns a hash of information regarding the difference between two baselines or
+a baseline and the stream (AKA "top of stream").
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item [activities|versions|baselines]
+
+Must specify one of [activities|versions|baselines]. Information will be
+returned based on this parameter.
+
+=item $baseline or $stream
+
+Specify the baseline or stream to compare to. If not specified a -predeccsor
+diffbl will be done. If a stream use "stream:<stream>" otherwise use
+"baseline:<baseline>" or simply "<baseline>".
+
+=item %opts
+
+Additional options.
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item %info
+
+Depending on whether activites, versions or baselines were specified, the
+returned hash will be constructed with the key being the activity, version
+string or baseline name as the key with additional information specified as the
+value.
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ unless ($type =~ /^activities$/i or
+ $type =~ /^versions$/i or
+ $type =~ /^baselines$/i) {
+ croak "Type must be one of activities, versions or baselines in "
+ . "Clearcase::UCM::Baseline::diff - not $type";
+ } # unless
+
+ my $myBaseline = "$self->{name}\@$self->{pvob}";
+
+ my $cmd = "diffbl -$type";
+
+ if ($baseline) {
+ if ($baseline =~ /(\S+):/) {
+ unless ($1 eq 'baseline' or $1 eq 'stream') {
+ croak "Baseline should be baseline:<baseline> or stream:<stream> or "
+ . "just <baseline>";
+ } # unless
+ } # if
+
+ $baseline .= "\@$self->{pvob}" unless $baseline =~ /\@/;
+
+ $cmd .= " $myBaseline $baseline";
+ } else {
+ $cmd .= " -predeccsor";
+ } # if
+
+ $Clearcase::CC->execute ($cmd);
+
+ return if $Clearcase::CC->status;
+
+ my @output = $Clearcase::CC->output;
+
+ my %info;
+
+ foreach (@output) {
+ next unless /^(\>\>|\<\<)/;
+
+ if (/(\>\>|\<\<)\s+(\S+)\@/) {
+ $info{$2} = Clearcase::UCM::Activity->new ($2, $self->{pvob});
+ } # if
+ } # foreach
+
+ return %info;
+} # diff
+
+1;
+
+=head1 DEPENDENCIES
+
+=head2 ClearSCM Perl Modules
+
+=for html <p><a href="/php/cvs_man.php?file=lib/Clearcase.pm">Clearcase</a></p>
+
+=head1 INCOMPATABILITIES
+
+None
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this module.
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2007, ClearSCM, Inc. All rights reserved.
+
+=cut
--- /dev/null
+=pod
+
+=head1 NAME $RCSfile: Pvob.pm,v $
+
+Object oriented interface to a UCM Pvob
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.1 $
+
+=item Created
+
+Fri May 14 18:16:16 PDT 2010
+
+=item Modified
+
+$Date: 2011/11/09 01:52:39 $
+
+=back
+
+=head1 SYNOPSIS
+
+Provides access to information about a Clearcase Pvob.
+
+ my $pvob = new Clearcase::UCM::Pvob ($name);
+
+=head1 DESCRIPTION
+
+This module implements a UCM Pvob object
+
+=head1 ROUTINES
+
+The following routines are exported:
+
+=cut
+
+package Clearcase::UCM::Pvob;
+
+use strict;
+use warnings;
+
+use Clearcase;
+use Clearcase::UCM::Stream;
+
+sub new ($) {
+ my ($class, $name) = @_;
+
+=pod
+
+=head2 new
+
+Construct a new Clearcase Pvob object.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item pvob name
+
+Name of pvob
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Clearcase Pvob object
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my $self = bless {
+ name => $name,
+ }, $class; # bless
+
+ return $self;
+} # new
+
+sub name () {
+ my ($self) = @_;
+
+=pod
+
+=head2 name
+
+Returns the name of the pvob
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item pvob's name
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{name};
+} # name
+
+sub streams () {
+ my ($self) = @_;
+
+=pod
+
+=head2 streams
+
+Returns an array of stream objects in the pvob
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item array of stream objects in the pvob
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my $cmd = "lsstream -short -invob $self->{name}";
+
+ $Clearcase::CC->execute ($cmd);
+
+ return if $Clearcase::CC->status;
+
+ my @streams;
+
+ push @streams, Clearcase::UCM::Stream->new ($_, $self->{name})
+ foreach ($Clearcase::CC->output);
+
+ return @streams;
+} # streams
+
+1;
+
+=head1 DEPENDENCIES
+
+=head2 ClearSCM Perl Modules
+
+=for html <p><a href="/php/cvs_man.php?file=lib/Clearcase.pm">Clearcase</a></p>
+
+=for html <p><a href="/php/cvs_man.php?file=lib/Clearcase/UCM/Baseline.pm">Clearcase::UCM::Baseline</a></p>
+
+=head1 INCOMPATABILITIES
+
+None
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this module.
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2007, ClearSCM, Inc. All rights reserved.
+
+=cut
--- /dev/null
+=pod
+
+=head1 NAME $RCSfile: Stream.pm,v $
+
+Object oriented interface to UCM Streams
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.8 $
+
+=item Created
+
+Fri May 14 18:16:16 PDT 2010
+
+=item Modified
+
+$Date: 2011/11/15 02:00:58 $
+
+=back
+
+=head1 SYNOPSIS
+
+Provides access to information about Clearcase Elements.
+
+ my $stream= new Clearcase::UCM::Stream ($name, $pvob);
+
+=head1 DESCRIPTION
+
+This module implements a UCM Stream object
+
+=head1 ROUTINES
+
+The following routines are exported:
+
+=cut
+
+package Clearcase::UCM::Stream;
+
+use strict;
+use warnings;
+
+use Clearcase;
+use Clearcase::UCM::Baseline;
+
+sub new ($$) {
+ my ($class, $stream, $pvob) = @_;
+
+=pod
+
+=head2 new
+
+Construct a new Clearcase Stream object.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item stream name
+
+Name of stream
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Clearcase Stream object
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my $self = bless {
+ name => $stream,
+ pvob => Clearcase::vobtag $pvob,
+ }, $class; # bless
+
+ return $self;
+} # new
+
+sub name () {
+ my ($self) = @_;
+
+=pod
+
+=head2 name
+
+Returns the name of the stream
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item stream's name
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{name};
+} # name
+
+sub pvob () {
+ my ($self) = @_;
+
+=pod
+
+=head2 pvob
+
+Returns the pvob of the stream
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item stream's pvob
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{pvob};
+} # pvob
+
+sub create ($$;$$) {
+ my ($self, $project, $pvob, $baseline, $opts) = @_;
+
+=pod
+
+=head2 create
+
+Creates a new UCM Stream Object
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item UCM Project (required)
+
+UCM Project this stream belongs to
+
+=item PVOB (Required)
+
+Project Vob
+
+=item baseline
+
+Baseline to set this stream to
+
+=item opts
+
+Options: Additional options to use (e.g. -readonly)
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $status
+
+Status from cleartool
+
+=item @output
+
+Ouput from cleartool
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ # Fill in object members
+ $self->{project} = $project;
+ $self->{pvob} = $pvob;
+
+ # Fill in opts
+ $opts ||= '';
+ $opts .= " -baseline $baseline"
+ if $baseline;
+
+ $self->{readonly} = $opts =~ /-readonly/;
+
+ # TODO: This should call the exists function
+ # Return the stream name if the stream already exists
+ my ($status, @output) =
+ $Clearcase::CC->execute ('lsstream -short ' . $self->{name});
+
+ return ($status, @output)
+ unless $status;
+
+ # Need to create the stream
+ return $Clearcase::CC->execute
+ ("mkstream $opts -in " . $self->{project} .
+ "\@" . $self->{pvob} .
+ ' ' . $self->{name});
+} # create
+
+sub remove () {
+ my ($self) = @_;
+
+=pod
+
+=head2 remove
+
+Removes UCM Stream
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item UCM Project (required)
+
+UCM Project this stream belongs to
+
+=item PVOB (Required)
+
+Project Vob
+
+=item baseline
+
+Baseline to set this stream to
+
+=item opts
+
+Options: Additional options to use (e.g. -readonly)
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $status
+
+Status from cleartool
+
+=item @output
+
+Ouput from cleartool
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $Clearcase::CC->execute
+ ('rmstream -f ' . $self->{name} . "\@" . $self->{pvob});
+} # rmStream
+
+sub baselines () {
+ my ($self) = @_;
+
+=pod
+
+=head2 baselines
+
+Returns baseline objects associated with the stream
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item @baselines
+
+An array of baseline objects for this stream
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my $cmd = "lsbl -short -stream $self->{name}\@$self->{pvob}";
+
+ $Clearcase::CC->execute ($cmd);
+
+ return if $Clearcase::CC->status;
+
+ my @baselines;
+
+ foreach ($Clearcase::CC->output) {
+ my $baseline = Clearcase::UCM::Baseline->new ($_, $self->{pvob});
+
+ push @baselines, $baseline;
+ } # foreach
+
+ return @baselines;
+} # baselines
+
+1;
+
+=head1 DEPENDENCIES
+
+=head2 ClearSCM Perl Modules
+
+=for html <p><a href="/php/cvs_man.php?file=lib/Clearcase.pm">Clearcase</a></p>
+
+=for html <p><a href="/php/cvs_man.php?file=lib/Clearcase/UCM/Baseline.pm">Clearcase::UCM::Baseline</a></p>
+
+=head1 INCOMPATABILITIES
+
+None
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this module.
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2007, ClearSCM, Inc. All rights reserved.
+
+=cut
--- /dev/null
+=pod
+
+=head1 NAME $RCSfile: View.pm,v $
+
+Object oriented interface to a Clearcase View
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.18 $
+
+=item Created
+
+Thu Dec 29 12:07:59 PST 2005
+
+=item Modified
+
+$Date: 2011/11/16 19:46:13 $
+
+=back
+
+=head1 SYNOPSIS
+
+Provides access to information about a Clearcase View. Note that some
+information about a view is not populated into the view object at
+object instantiation. This is because members such as labels can be
+very long and time consuming to acquire. When the caller request such
+fields they are expanded.
+
+ # Create View object
+ my $view = new Clearcase::View (tag => 'test');
+
+ # Access member variables...
+ display "View:\t\t \t" . $view->tag;
+ display "Accessed by:\t\t" . $view->accessed_by;
+ display "Accessed date:\t\t" . $view->accessed_date;
+ display "Access path:\t\t" . $view->access_path;
+ display "Active:\t\t\t" . $view->active;
+
+ display_nolf MAGENTA . "Additional groups:\t";
+
+ foreach ($view->additional_groups) {
+ display_nolf "$_ ";
+ } # foreach
+
+ display '';
+
+ display "Created by:\t\t" . $view->created_by;
+ display "Created date:\t\t" . $view->created_date;
+ display "CS updated by:\t\t" . $view->cs_updated_by;
+ display "CS updated date:\t" . $view->cs_updated_date;
+ display "Global path:\t\t" . $view->gpath;
+ display "Group:\t\t\t" . $view->group;
+ display "Group mode:\t\t" . $view->group_mode;
+ display "Host:\t\t\t" . $view->host;
+ display "Mode:\t\t\t" . $view->mode;
+ display "Modified by:\t\t" . $view->modified_by;
+ display "Modified date:\t\t" . $view->modified_date;
+ display "Other mode:\t\t" . $view->other_mode;
+ display "Owner:\t\t\t" . $view->owner;
+ display "Owner mode:\t\t" . $view->owner_mode;
+ display "Properties:\t\t" . $view->properties;
+ display "Region:\t\t\t" . $view->region;
+ display "Server host:\t\t" . $view->shost;
+ display "Text mode:\t\t" . $view->text_mode;
+ display "UUID:\t\t\t" . $view->uuid;
+
+ display_nolf "Type:\t\t\t";
+
+ if ($view->snapshot) {
+ display_nolf 'snapshot';
+ } else {
+ display_nolf 'dynamic';
+ } # if
+
+ if ($view->ucm) {
+ display_nolf ',ucm';
+ } # if
+
+ display '';
+
+ # View manipulation
+ my $new_view = new Clearcase::View ($ENV{USER} . '_testview');
+
+ $new_view->create;
+
+ # Start new view
+ $new_view->start;
+
+ # Set to view
+ $new_view->set;
+
+ # Stop view
+ $new_view->stop;
+
+ # Stop view server process
+ $new_view->kill;
+
+ # Remove view
+ if ($new_view->exists) {
+ $new_view->remove;
+ } # if
+
+=head1 DESCRIPTION
+
+This module implements an object oriented interface to a Clearcase
+view.
+
+=head1 ROUTINES
+
+The following routines are exported:
+
+=cut
+
+package Clearcase::View;
+
+use strict;
+use warnings;
+
+use Clearcase;
+use Display;
+
+sub new ($;$) {
+ my ($class, $tag, $region) = @_;
+
+=pod
+
+=head2 new (tag)
+
+Construct a new Clearcase View object. Note that not all members are
+initially populated because doing so would be time consuming. Such
+member variables will be expanded when accessed.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item tag
+
+View tag to be instantiated. You can use either an object oriented call
+(i.e. my $view = new Clearcase::View (tag => 'my_new_view')) or the
+normal call (i.e. my $vob = new Clearcase::View ('my_new_view')). You
+can also instantiate a new view by supplying a tag and then later
+calling the create method.
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Clearcase View object
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my $self = bless { tag => $tag }, $class;
+
+ $self->updateViewInfo ($region);
+
+ return $self;
+} # new
+
+sub accessed_by () {
+ my ($self) = @_;
+
+=pod
+
+=head2 accessed_by
+
+Returns the user name of the last user to access the view.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item user name
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{accessed_by};
+} # accessed_by
+
+sub accessed_date () {
+ my ($self) = @_;
+
+=pod
+
+=head2 accessed_date
+
+Returns the date the view was last accessed.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item access date
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{accessed_date};
+} # accessed_date
+
+sub access_path () {
+ my ($self) = @_;
+
+=pod
+
+=head2 access_path
+
+Returns the access path of the view.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item access path
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{access_path};
+} # access_path
+
+sub active () {
+ my ($self) = @_;
+
+=pod
+
+=head2 active
+
+Returns true if the view is active
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item boolean
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{active};
+} # active
+
+sub additional_groups () {
+ my ($self) = @_;
+
+=pod
+
+=head2 additional_groups
+
+Returns the additional groups that have permission to access this
+view.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item An array of additional groups
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ if ($self->{additional_groups}) {
+ return @{$self->{additional_groups}};
+ } else {
+ return ();
+ } # if
+} # additional_groups
+
+sub created_by () {
+ my ($self) = @_;
+
+=pod
+
+=head2 created_by
+
+Returns the user name who created the view
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item user name
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{created_by};
+} # created_by
+
+sub created_date () {
+ my ($self) = @_;
+
+=pod
+
+=head2 created_date
+
+Returns the date the view was created.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item date
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{created_date};
+} # created_date
+
+sub cs_updated_by () {
+ my ($self) = @_;
+
+=pod
+
+=head2 cs_updated_date
+
+Returns the user name of the last user to access the view.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item date
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{cs_updated_by};
+} # cs_updated_by
+
+sub cs_updated_date () {
+ my ($self) = @_;
+
+=pod
+
+=head2 dynamic
+
+Returns the date the config spec for this view was updated.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item date
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{cs_updated_date};
+} # cs_updated_date
+
+sub dynamic () {
+ my ($self) = @_;
+
+=pod
+
+=head2 dynamic
+
+Returns true if the view is a dynamic view - false otherwise.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item boolean
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->type eq 'dynamic';
+} # dynamic
+
+sub gpath () {
+ my ($self) = @_;
+
+=pod
+
+=head2 gpath
+
+Returns the global path to the view
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item global path
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{gpath};
+} # gpath
+
+sub group () {
+ my ($self) = @_;
+
+=pod
+
+=head2 group
+
+Returns the group of the user who created the view.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item group name
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{group};
+} # group
+
+sub group_mode () {
+ my ($self) = @_;
+
+=pod
+
+=head2 group_mode
+
+Returns the group mode of the view.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item A string representing the group mode
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{group_mode};
+} # group_mode
+
+sub host () {
+ my ($self) = @_;
+
+=pod
+
+=head2 host
+
+Returns the host that the view resides on
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item host
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{host};
+} # host
+
+sub mode () {
+ my ($self) = @_;
+
+=pod
+
+=head2 mode
+
+Returns the numeric mode representing the view's access mode
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item numeric mode
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{mode};
+} # mode
+
+sub modified_by () {
+ my ($self) = @_;
+
+=pod
+
+=head2 modified_by
+
+Returns the user name of the last user to modify the view.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item user name
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{modified_by};
+} # modified_by
+
+sub modified_date () {
+ my ($self) = @_;
+
+=pod
+
+=head2 modified_date
+
+Returns the date the view was last modified.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item date
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{modified_date};
+} # modified_date
+
+sub other_mode () {
+ my ($self) = @_;
+
+=pod
+
+=head2 other_mode
+
+Returns the mode for other for the view.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item A string repesenting the other mode
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{other_mode};
+} # other_mode
+
+sub owner () {
+ my ($self) = @_;
+
+=pod
+
+=head2 owner
+
+Returns the user name of the owner of the view.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item user name
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{owner}
+} # owner
+
+sub owner_mode () {
+ my ($self) = @_;
+
+=pod
+
+=head2 owner_mode
+
+Returns the mode for the owner for the view.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item A string repesenting the other mode
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{owner_mode}
+} # owner_mode
+
+sub properties () {
+ my ($self) = @_;
+
+=pod
+
+=head2 properties
+
+Returns the properties of the view.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item properties
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{properties};
+} # properties
+
+sub region () {
+ my ($self) = @_;
+
+=pod
+
+=head2 region
+
+Returns the region of the view
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item region
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{region};
+} # region
+
+sub shost () {
+ my ($self) = @_;
+
+=pod
+
+=head2 shost
+
+Returns the server host of the view
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item server host
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{shost};
+} # shost
+
+sub snapshot () {
+ my ($self) = @_;
+
+=pod
+
+=head2 snapshot
+
+Returns true if the view is a snapshot view - false otherwise.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item boolean
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->type eq 'snapshot';
+} # snapshot
+
+sub webview () {
+ my ($self) = @_;
+
+=pod
+
+=head2 webview
+
+Returns true if the view is a webview - false otherwise.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item boolean
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->type eq 'webview';
+} # webview
+
+sub tag () {
+ my ($self) = @_;
+
+=pod
+
+=head1 tag
+
+Returns the tag for this view.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item tag
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{tag};
+ } # tag
+
+sub text_mode () {
+ my ($self) = @_;
+
+=pod
+
+=head2 text_mode
+
+Returns the text_mode of the view
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item text mode
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{text_mode};
+} # tag
+
+sub type () {
+ my ($self) = @_;
+
+=pod
+
+=head2 type
+
+Returns the type of the view.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item type
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{type} ? $self->{type} : 'Unknown';
+} # type
+
+sub ucm () {
+ my ($self) = @_;
+
+=pod
+
+=head2 ucm
+
+Returns true if the view is a UCM view.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item boolean
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{ucm};
+} # ucm
+
+sub uuid () {
+ my ($self) = @_;
+
+=pod
+
+=head2 uuid
+
+Returns the uuid for the view.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item uuid
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{uuid};
+} # uuid
+
+sub exists () {
+ my ($self) = @_;
+
+=pod
+
+=head3 exists
+
+Returns true if the view exists - false otherwise.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item boolean
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my ($status, @output) = $Clearcase::CC->execute ("lsview $self->{tag}");
+
+ return !$status;
+} # exists
+
+sub create (;$$$) {
+ my ($self, $host, $vws, $region) = @_;
+
+=pod
+
+=head2 create
+
+Creates a view
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item host
+
+Host to create the view on. Default is to use -stgloc -auto.
+
+=item vws
+
+View working storage directory to use. Default is to use -stgloc -auto.
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $status
+
+Status from cleartool
+
+=item @output
+
+Ouput from cleartool
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $region ||= $Clearcase::CC->region;
+
+ if ($self->exists) {
+ $self->updateViewInfo ($region);
+
+ return (0, ())
+ } # if
+
+ my ($status, @output);
+
+ if ($host && $vws) {
+ ($status, @output) =
+ $Clearcase::CC->execute ("mkview -tag $self->{tag} -region $region "
+ . "-host $host -hpath $vws -gpath $vws $vws");
+ } else {
+ # Note this requires that -stgloc's work and that using -auto is not a
+ # problem.
+ ($status, @output) =
+ $Clearcase::CC->execute ("mkview -tag $self->{tag} -stgloc -auto");
+ } # if
+
+ $self->updateViewInfo ($region);
+
+ return ($status, @output);
+} # create
+
+sub createUCM ($$) {
+ my ($self, $stream, $pvob, $region) = @_;
+
+=pod
+
+=head2 createUCM
+
+Create a UCM view
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item streamName
+
+Name of stream to attach new view to
+
+=item pvob
+
+Name of project vob
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item status
+
+Integer status
+
+=item output
+
+Array of output
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $region ||= $Clearcase::CC->region;
+
+ return (0, ())
+ if $self->exists;
+
+ # Update object members
+ $self->{stream} = $stream;
+ $self->{pvob} = $pvob;
+
+ # Need to create the view
+ my ($status, @output) =
+ $Clearcase::CC->execute ("mkview -tag $self->{tag} -stream "
+ . "$self->{stream}\@$self->{pvob} -stgloc -auto");
+
+ return ($status, @output)
+ if $status;
+
+ $self->updateViewInfo ($region);
+
+ return ($status, @output);
+} # createUCM
+
+sub remove () {
+ my ($self) = @_;
+
+=pod
+
+=head3 remove
+
+Removes the view.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $status
+
+Status from cleartool
+
+=item @output
+
+Ouput from cleartool
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return (0, ())
+ unless $self->exists;
+
+ my ($status, @output);
+
+ if ($self->dynamic) {
+ ($status, @output) = $Clearcase::CC->execute (
+ "rmview -force -tag $self->{tag}"
+ );
+ } else {
+ error 'Removal of snapshot views not implemented yet', 1;
+ #($status, @output) = $Clearcase::CC->execute (
+ # "rmview -force $self->{snapshot_view_pname}"
+ #);
+ } # if
+
+ return ($status, @output);
+} # remove
+
+sub start () {
+ my ($self) = @_;
+
+=pod
+
+=head2 start
+
+Starts the view.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $status
+
+Status from cleartool
+
+=item @output
+
+Ouput from cleartool
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $Clearcase::CC->execute ("startview $self->{tag}");
+} # start
+
+sub stop () {
+ my ($self) = @_;
+
+=pod
+
+=head2 stop
+
+Stops the view.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $status
+
+Status from cleartool
+
+=item @output
+
+Ouput from cleartool
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $Clearcase::CC->execute ("endview $self->{tag}");
+} # stop
+
+sub kill () {
+ my ($self) = @_;
+
+=pod
+
+=head2 kill
+
+Stops the view at the view_server process if nobody else is accessing the view.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $status
+
+Status from cleartool
+
+=item @output
+
+Ouput from cleartool
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $Clearcase::CC->execute ("endview -server $self->{tag}");
+} # kill
+
+sub set () {
+ my ($self) = @_;
+
+=pod
+
+=head3 set
+
+Starts the view then changes directory the to view's root.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $status
+
+Status from cleartool
+
+=item @output
+
+Ouput from cleartool
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my ($status, @output) = $self->start;
+
+ chdir "$Clearcase::VIEWTAG_PREFIX/$self->{tag}";
+
+ return ($status, @output);
+} # set
+
+sub updateViewInfo ($$) {
+ my ($self, $region) = @_;
+
+ $region ||= $Clearcase::CC->region;
+
+ my ($status, @output) = $Clearcase::CC->execute (
+ "lsview -region $region -long -properties -full $self->{tag}"
+ );
+
+ # Assuming this view is an empty shell of an object that the user may possibly
+ # use the create method on, return our blessings...
+
+ # No longer assume that. Could equally be the case where the view server
+ # failed to respond. Carry on then...return if $status != 0;
+
+ # Defaults
+ $self->{type} = 'dynamic';
+ $self->{ucm} = 0;
+ $self->{additional_groups} = '';
+
+ foreach (@output) {
+ if (/Global path: (.*)/) {
+ $self->{gpath} = $1;
+ } elsif (/Server host: (.*)/) {
+ $self->{shost} = $1;
+ } elsif (/Region: (.*)/) {
+ $self->{region} = $1;
+ } elsif (/Active: (.*)/) {
+ $self->{active} = ($1 eq 'YES') ? 1 : 0;
+ } elsif (/View uuid: (.*)/) {
+ $self->{uuid} = $1;
+ } elsif (/View on host: (.*)/) {
+ $self->{host} = $1;
+ } elsif (/View server access path: (.*)/) {
+ $self->{access_path} = $1;
+ } elsif (/View attributes: (.*)/) {
+ my $view_attributes = $1;
+ $self->{type} = $view_attributes =~ /webview/
+ ? 'webview'
+ : $view_attributes =~ /snapshot/
+ ? 'snapshot'
+ : 'dynamic';
+ $self->{ucm} = $view_attributes =~ /ucmview/
+ ? 1
+ : 0;
+ } elsif (/Created (\S+) by (.+)/) {
+ $self->{created_date} = $1;
+ $self->{created_by} = $2;
+ } elsif (/Last modified (\S+) by (.+)/) {
+ $self->{modified_date} = $1;
+ $self->{modified_by} = $2;
+ } elsif (/Last accessed (\S+) by (.+)/) {
+ $self->{accessed_date} = $1;
+ $self->{accessed_by} = $2;
+ } elsif (/Last config spec update (\S+) by (.+)/) {
+ $self->{cs_updated_date} = $1;
+ $self->{cs_updated_by} = $2;
+ } elsif (/Text mode: (\S+)/) {
+ $self->{text_mode} = $1;
+ } elsif (/Properties: (.*)/) {
+ $self->{properties} = $1;
+ } elsif (/Owner: (\S+)\s+: (\S+) /) {
+ $self->{owner} = $1;
+ $self->{owner_mode} = $2;
+ } elsif (/Group: (.+)\s+:\s+(\S+)\s+/) {
+ $self->{group} = $1;
+ $self->{group_mode} = $2;
+ } elsif (/Other:\s+: (\S+) /) {
+ $self->{other_mode} = $1;
+ } elsif (/Additional groups: (.*)/) {
+ my @additional_groups = split /\s+/, $1;
+ $self->{additional_groups} = \@additional_groups;
+ } # if
+ } # foreach
+
+ # Change modes to numeric
+ $self->{mode} = 0;
+
+ if ($self->{owner_mode}) {
+ $self->{mode} += 400 if $self->{owner_mode} =~ /r/;
+ $self->{mode} += 200 if $self->{owner_mode} =~ /w/;
+ $self->{mode} += 100 if $self->{owner_mode} =~ /x/;
+ $self->{mode} += 40 if $self->{group_mode} =~ /r/;
+ $self->{mode} += 20 if $self->{group_mode} =~ /w/;
+ $self->{mode} += 10 if $self->{group_mode} =~ /x/;
+ $self->{mode} += 4 if $self->{other_mode} =~ /r/;
+ $self->{mode} += 2 if $self->{other_mode} =~ /w/;
+ $self->{mode} += 1 if $self->{other_mode} =~ /x/;
+ } # if
+
+ return;
+} # updateViewInfo
+
+1;
+
+=pod
+
+=head2 DEPENDENCIES
+
+=for html <p><a href="/php/cvs_man.php?file=lib/Clearcase.pm">Clearcase</a></p>
+
+=head2 INCOMPATABILITIES
+
+None
+
+=head2 BUGS AND LIMITATIONS
+
+There are no known bugs in this module.
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head2 LICENSE AND COPYRIGHT
+
+Copyright (c) 2007, ClearSCM, Inc. All rights reserved.
+
+=cut
--- /dev/null
+=pod
+
+=head1 NAME $RCSfile: Views.pm,v $
+
+Object oriented interface to Clearcase Views
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.12 $
+
+=item Created
+
+Dec 29 12:07:59 PST 2005
+
+=item Modified
+
+$Date: 2011/11/16 19:46:13 $
+
+=back
+
+=head1 SYNOPSIS
+
+Provides access to information about Clearcase Views.
+
+ my $views = new Clearcase::Views;
+
+ my $nbr_views = $views->views;
+ my @view_list = $views->views;
+
+ display "Clearcase Views\n";
+
+ display "Number of views:\t\t" . $nbr_views;
+ display "View list:\n";
+
+ display "\t$_" foreach (@view_list);
+
+=head1 DESCRIPTION
+
+This module implements an object oriented interface to Clearcase
+views.
+
+=head1 ROUTINES
+
+The following routines are exported:
+
+=cut
+
+package Clearcase::Views;
+
+use strict;
+use warnings;
+
+use Clearcase;
+
+sub new (;$) {
+ my ($class, $region) = @_;
+
+=pod
+
+=head2 new
+
+Construct a new Clearcase Views object.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Clearcase Views object
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $region ||= $Clearcase::CC->region;
+
+ my ($status, @output) =
+ $Clearcase::CC->execute ("lsview -short -region $region");
+
+ $class = bless {
+ views => \@output,
+ }, $class; # bless
+
+ return $class;
+} # new
+
+sub views () {
+ my ($self) = @_;
+
+=pod
+
+=head2 views
+
+Return a list of view tags in an array context or the number of views in
+a scalar context.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item List of views or number of views
+
+Array of view tags in an array context or the number of views in a scalar context.
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ if (wantarray) {
+ return $self->{views} ? sort @{$self->{views}} : ();
+ } else {
+ return $self->{views} ? scalar @{$self->{views}} : 0;
+ } #if
+} # views
+
+sub dynamic () {
+ my ($self) = @_;
+
+=pod
+
+=head2 dynamic
+
+Return the number of dynamic views
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item number of dynamic views
+
+Returns the number of dynamic views in the region
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $self->updateViewInfo if !defined $self->{dynamic};
+ return $self->{dynamic};
+} # dynamic
+
+sub ucm () {
+ my ($self) = @_;
+
+=pod
+
+=head2 ucm
+
+Return the number of ucm views
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item number of ucm views
+
+Returns the number of ucm views in the region
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $self->updateViewInfo if !defined $self->{ucm};
+ return $self->{ucm};
+} # ucm
+
+sub snapshot () {
+ my ($self) = @_;
+
+=pod
+
+=head2 snapshot
+
+Return the number of snapshot views
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item number of snapshot views
+
+Returns the number of snapshot views in the region
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $self->updateViewInfo if !defined $self->{snapshot};
+ return $self->{snapshot};
+} # snapshot
+
+sub web () {
+ my ($self) = @_;
+
+=pod
+
+=head2 web
+
+Return the number of web views
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item number of web views
+
+Returns the number of web views in the region
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $self->updateViewInfo if !defined $self->{web};
+ return $self->{web};
+} # web
+
+sub updateViewInfo ($) {
+ my ($self) = @_;
+
+ my ($dynamic, $web, $ucm, $snapshot) = (0, 0, 0, 0);
+
+ foreach ($self->views) {
+ my ($status, @lsview_out) = $Clearcase::CC->execute ("lsview -properties -full $_");
+
+ next
+ if $status;
+
+ foreach (@lsview_out) {
+ if (/Properties/) {
+ $dynamic++
+ if /dynamic/;
+ $snapshot++
+ if /snapshot/ and not /webview/;
+ $ucm++
+ if /ucmview/;
+ $web++
+ if /webview/;
+ last;
+ } # if
+ } # foreach
+
+ $self->{dynamic} = $dynamic;
+ $self->{web} = $web;
+ $self->{ucm} = $ucm;
+ $self->{snapshot} = $snapshot;
+ } # foreach
+
+ return
+} # updateViewInfo
+
+1;
+
+=head1 DEPENDENCIES
+
+=for html <p><a href="/php/cvs_man.php?file=lib/Clearcase.pm">Clearcase</a></p>
+
+=head1 INCOMPATABILITIES
+
+None
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this module.
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2007, ClearSCM, Inc. All rights reserved.
+
+=cut
--- /dev/null
+=pod
+
+=head1 NAME $RCSfile: Vob.pm,v $
+
+Object oriented interface to a Clearcase VOB
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.15 $
+
+=item Created
+
+Thu Dec 29 12:07:59 PST 2005
+
+=item Modified
+
+$Date: 2011/11/16 19:46:13 $
+
+=back
+
+=head1 SYNOPSIS
+
+Provides access to information about a Clearcase VOB. Note that information
+about the number of elements, branches, etc. that is provided by countdb are not
+initially instantiated with the VOB object, rather those member variables are
+expanded if and when accessed. This helps the VOB object to be more efficient.
+
+ # Create VOB object
+ my $vob = new Clearcase::Vob (tag => "/vobs/test");
+
+ # Access member variables...
+ display "Tag:\t\t" . $vob->tag;
+ display "Global path:\t" . $vob->gpath;
+ display "Sever host:\t" . $vob->shost;
+ display "Access:\t\t" . $vob->access;
+ display "Mount options:\t" . $vob->mopts;
+ display "Region:\t\t" . $vob->region;
+ display "Active:\t\t" . $vob->active;
+ display "Replica UUID:\t" . $vob->replica_uuid;
+ display "Host:\t\t" . $vob->host;
+ display "Access path:\t" . $vob->access_path;
+ display "Family UUID:\t" . $vob->family_uuid;
+
+ # This members are not initially expanded until accessed
+ display "Elements:\t" . $vob->elements;
+ display "Branches:\t" . $vob->branches;
+ display "Versions:\t" . $vob->versions;
+ display "DB Size:\t" . $vob->dbsize;
+ display "Adm Size:\t" . $vob->admsize;
+ display "CT Size:\t" . $vob->ctsize;
+ display "DO Size:\t" . $vob->dbsize;
+ display "Src Size:\t" . $vob->srcsize;
+ display "Size:\t\t" . $vob->size;
+
+ # VOB manipulation
+ display "Umounting " . $vob->tag . "...";
+
+ $vob->umount;
+
+ display "Mounting " . $vob->tag . "...";
+
+ $vob->mount;
+
+=head2 DESCRIPTION
+
+This module, and others below the Clearcase directory, implement an object
+oriented approach to Clearcase. In general Clearcase entities are made into
+objects that can be manipulated easily in Perl. This module is the main or
+global module. Contained herein are members and methods of a general or global
+nature. Also contained here is an IPC interface to cleartool such that cleartool
+runs in the background andcommands are fed to it via the exec method. When
+making repeated calls to cleartool this can result in a substantial savings of
+time as most operating systems' fork/exec sequence is time consuming. Factors of
+8 fold improvement have been measured.
+
+Additionally a global variable, $cc, is implemented from this module such that
+you should not need to instantiate another one, though you could.
+
+=head2 ROUTINES
+
+The following routines are exported:
+
+=cut
+
+package Clearcase::Vob;
+
+use strict;
+use warnings;
+
+use Clearcase;
+use OSDep;
+
+sub new ($) {
+ my ($class, $tag) = @_;
+
+=pod
+
+=head2 new (tag)
+
+Construct a new Clearcase VOB object. Note that not all members are
+initially populated because doing so would be time consuming. Such
+member variables will be expanded when accessed.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item tag
+
+VOB tag to be instantiated. You can use either an object oriented call
+(i.e. my $vob = new Clearcase::Vob (tag => "/vobs/test")) or the
+normal call (i.e. my $vob = new Clearcase::Vob ("/vobs/test")). You
+can also instantiate a new vob by supplying a tag and then later
+calling the create method.
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Clearcase VOB object
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $class = bless {
+ tag => $tag
+ }, $class;
+
+ $class->updateVobInfo;
+
+ return $class;
+} # new
+
+sub tag () {
+ my ($self) = @_;
+
+=pod
+
+=head2 tag
+
+Returns the VOB's tag
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item VOB's tag
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{tag};
+} # tag
+
+sub gpath () {
+ my ($self) = @_;
+
+=pod
+
+=head2 gpath
+
+Returns the VOB's global path
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item VOB's gpath
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{gpath};
+} # gpath
+
+sub shost () {
+ my ($self) = @_;
+
+=pod
+
+=head2 shost
+
+Returns the VOB's server host
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item VOB's server host
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{shost};
+} # shost
+
+sub access () {
+ my ($self) = @_;
+
+=pod
+
+=head2 access
+
+Returns the type of VOB access
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item access
+
+Returns either public for public VOBs or private for private VOBs
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{access};
+} # access
+
+sub mopts () {
+ my ($self) = @_;
+
+=pod
+
+=head2 mopts
+
+Returns the mount options
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item VOB's mount options
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{mopts};
+} # mopts
+
+sub region () {
+ my ($self) = @_;
+
+=pod
+
+=head3 region
+
+Returns the region for this VOB tag
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item region
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{region};
+} # region
+
+sub active () {
+ my ($self) = @_;
+
+=pod
+
+=head2 active
+
+Returns that active status (whether or not the vob is currently mounted) of the
+VOB
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Returns YES for an active VOB or NO for an inactive one
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{active};
+} # active
+
+sub replica_uuid () {
+ my ($self) = @_;
+
+=pod
+
+=head2 replica_uuid
+
+Returns the VOBS replica_uuid
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item VOB replica_uuid
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{replica_uuid};
+} # replica_uuid
+
+sub host () {
+ my ($self) = @_;
+
+=pod
+
+=head2 host
+
+Returns the VOB's host
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item VOB's host
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{host};
+} # host
+
+sub access_path () {
+ my ($self) = @_;
+
+=pod
+
+=head2 access_path
+
+Returns the VOB's access path
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item VOB access path
+
+This is the path relative to the VOB's host
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{access_path};
+} # access_path
+
+sub family_uuid () {
+ my ($self) = @_;
+
+=pod
+
+=head2 family_uuid
+
+Returns the VOB family UUID
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item VOB family UUID
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{family_uuid};
+} # family_uuid
+
+sub vob_registry_attributes () {
+ my ($self) = @_;
+
+=pod
+
+=head2 vob_registry_attributes
+
+Returns the VOB Registry Attributes
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item VOB Registry Attributes
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{vob_registry_attributes};
+} # vob_registry_attributes
+
+sub expand_space () {
+ my ($self) = @_;
+
+ my ($status, @output) = $Clearcase::CC->execute ("space -vob $self->{tag}");
+
+ # Initialize fields in case of command failure
+ $self->{dbsize} = 0;
+ $self->{admsize} = 0;
+ $self->{ctsize} = 0;
+ $self->{dosize} = 0;
+ $self->{srcsize} = 0;
+ $self->{size} = 0;
+
+ foreach (@output) {
+ if (/(\d*\.\d).*VOB database(.*)/) {
+ $self->{dbsize} = $1;
+ } elsif (/(\d*\.\d).*administration data(.*)/) {
+ $self->{admsize} = $1;
+ } elsif (/(\d*\.\d).*cleartext pool(.*)/) {
+ $self->{ctsize} = $1;
+ } elsif (/(\d*\.\d).*derived object pool(.*)/) {
+ $self->{dosize} = $1;
+ } elsif (/(\d*\.\d).*source pool(.*)/) {
+ $self->{srcsize} = $1;
+ } elsif (/(\d*\.\d).*Subtotal(.*)/) {
+ $self->{size} = $1;
+ } # if
+ } # foreach
+
+ return;
+} # expand_space
+
+sub countdb () {
+ my ($self) = @_;
+
+ # Set values to zero in case we cannot get the right values from countdb
+ $self->{elements} = 0;
+ $self->{branches} = 0;
+ $self->{versions} = 0;
+
+ # Countdb needs to be done in the vob's db directory
+ my $cwd = `pwd`;
+
+ chomp $cwd;
+ chdir "$self->{gpath}/db";
+
+ my $cmd = "$Clearcase::COUNTDB vob_db 2>&1";
+ my @output = `$cmd`;
+
+ if ($? != 0) {
+ chdir $cwd;
+ return;
+ } # if
+
+ chomp @output;
+
+ # Parse output
+ foreach (@output) {
+ if (/^ELEMENT\s*:\s*(\d*)/) {
+ $self->{elements} = $1;
+ } elsif (/^BRANCH\s*:\s*(\d*)/) {
+ $self->{branches} = $1;
+ } elsif (/^VERSION\s*:\s*(\d*)/) {
+ $self->{versions} = $1;
+ } # if
+ } # foreach
+
+ chdir $cwd;
+
+ return;
+} # countdb
+
+sub elements () {
+ my ($self) = @_;
+
+=pod
+
+=head2 elements
+
+Returns the number of elements in the VOB (obtained via countdb)
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item number of elements
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $self->countdb if !$self->{elements};
+
+ return $self->{elements};
+} # elements
+
+sub branches () {
+ my ($self) = @_;
+
+=pod
+
+=head3 branches
+
+Returns the number of branch types in the vob
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item number of branch types
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $self->countdb if !$self->{branches};
+
+ return $self->{branches};
+} # branches
+
+sub versions () {
+ my ($self) = @_;
+
+=pod
+
+=head2 versions
+
+Returns the number of element versions in the VOB
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item number of element versions
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $self->countdb if !$self->{versions};
+
+ return $self->{versions};
+} # versions
+
+sub dbsize () {
+ my ($self) = @_;
+
+=pod
+
+=head3 dbsize
+
+Returns the size of the VOB's database
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item database size
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $self->expand_space if !$self->{dbsize};
+
+ return $self->{dbsize};
+} # dbsize
+
+sub admsize () {
+ my ($self) = @_;
+
+=pod
+
+=head2 admsize
+
+Returns the size of administrative data in the VOB
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item adminstrative size
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $self->expand_space if !$self->{admsize};
+
+ return $self->{admsize};
+} # admsize
+
+sub ctsize () {
+ my ($self) = @_;
+
+=pod
+
+=head3 ctsize
+
+Returns the size of the cleartext pool
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item cleartext pool size
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $self->expand_space if !$self->{ctsize};
+
+ return $self->{ctsize};
+} # ctsize
+
+sub dosize () {
+ my ($self) = @_;
+
+=pod
+
+=head2 dosize
+
+Returns the size of the derived object pool
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item derived object pool size
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $self->expand_space if !$self->{dosize};
+
+ return $self->{dosize};
+} # dosize
+
+sub srcsize () {
+ my ($self) = @_;
+
+=pod
+
+=head2 srcsize
+
+Returns the size of the source pool
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item source pool size
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $self->expand_space if !$self->{srcsize};
+
+ return $self->{srcsize};
+} # srcsize
+
+sub size () {
+ my ($self) = @_;
+
+=pod
+
+=head2 size
+
+Returns the size of the VOB
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item size
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $self->expand_space if !$self->{size};
+
+ return $self->{size};
+} # size
+
+sub mount () {
+ my ($self) = @_;
+
+=pod
+
+=head2 mount
+
+Mount the current VOB
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $status
+
+Status of the mount command
+
+=item @output
+
+An array of lines output from the cleartool mount command
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return 0 if $self->{active} && $self->{active} eq "YES";
+
+ my ($status, @output) = $Clearcase::CC->execute ("mount $self->{tag}");
+
+ return ($status, @output);
+} # mount
+
+sub umount () {
+ my ($self) = @_;
+
+=pod
+
+=head3 umount
+
+Unmounts the current VOB
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $status
+
+Status from cleartool
+
+=item @output
+
+Ouput from cleartool
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my ($status, @output) = $Clearcase::CC->execute ("umount $self->{tag}");
+
+ return ($status, @output);
+} # umount
+
+sub exists () {
+ my ($self) = @_;
+
+=pod
+
+=head2 exists
+
+Returns true or false if the VOB exists
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item boolean
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my ($status, @output) = $Clearcase::CC->execute ("lsvob $self->{tag}");
+
+ return !$status;
+} # exists
+
+sub create (;$$$) {
+ my ($self, $host, $vbs, $comment) = @_;
+
+=pod
+
+=head2 create
+
+Creates a VOB. First instantiate a VOB object with a tag. Then call create. A
+small subset of parameters is supported for create.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $host (optional)
+
+Host to create the vob on. Default is the current host.
+
+=item $vbs (optional)
+
+VOB storage area. This is a global pathname to the VOB storage
+area. Default will attempt to use -stgloc -auto.
+
+=item $comment (optional)
+
+Comment for this VOB's creation. Default is -nc
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $status
+
+Status from cleartool
+
+=item @output
+
+Ouput from cleartool
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return (0, ()) if $self->exists;
+
+ $comment = Clearcase::setComment $comment;
+
+ my ($status, @output);
+
+ if ($host && $vbs) {
+ ($status, @output) = $Clearcase::CC->execute (
+ "mkvob -tag $self->{tag} $comment -host $host -hpath $vbs "
+ . "-gpath $vbs $vbs");
+ } else {
+ # Note this requires that -stgloc's work and that using -auto is not a
+ # problem.
+ ($status, @output) =
+ $Clearcase::CC->execute ("mkvob -tag $self->{tag} $comment "
+ . "-stgloc -auto");
+ } # if
+
+ $self->updateVobInfo;
+
+ return ($status, @output);
+} # create
+
+sub remove () {
+ my ($self) = @_;
+
+=pod
+
+=head2 remove
+
+Removed this VOB
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $status
+
+Status from cleartool
+
+=item @output
+
+Ouput from cleartool
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $Clearcase::CC->execute ("rmvob -force $self->{gpath}");
+} # remove
+
+sub updateVobInfo ($$) {
+ my ($self) = @_;
+
+ my ($status, @output) = $Clearcase::CC->execute ("lsvob -long $self->{tag}");
+
+ # Assuming this vob is an empty shell of an object that the user may possibly
+ # use the create method on, return our blessings...
+ return if $status != 0;
+
+ foreach (@output) {
+ if (/Global path: (.*)/) {
+ $self->{gpath} = $1;
+ } elsif (/Server host: (.*)/) {
+ $self->{shost} = $1;
+ } elsif (/Access: (.*)/) {
+ $self->{access} = $1;
+ } elsif (/Mount options: (.*)/) {
+ $self->{mopts} = $1;
+ } elsif (/Region: (.*)/) {
+ $self->{region} = $1;
+ } elsif (/Active: (.*)/) {
+ $self->{active} = $1;
+ } elsif (/Vob tag replica uuid: (.*)/) {
+ $self->{replica_uuid} = $1;
+ } elsif (/Vob on host: (.*)/) {
+ $self->{host} = $1;
+ } elsif (/Vob server access path: (.*)/) {
+ $self->{access_path} = $1;
+ } elsif (/Vob family uuid: (.*)/) {
+ $self->{family_uuid} = $1;
+ } elsif (/Vob registry attributes: (.*)/) {
+ $self->{vob_registry_attributes} = $1;
+ } # if
+ } # foreach
+
+ return;
+} # getVobInfo
+
+1;
+
+=pod
+
+=head2 DEPENDENCIES
+
+=head3 ClearSCM Perl Modules
+
+=for html <p><a href="/php/cvs_man.php?file=lib/Clearcase.pm">Clearcase</a></p>
+
+=for html <p><a href="/php/cvs_man.php?file=lib/OSDep.pm">OSdep</a></p>
+
+=head2 BUGS AND LIMITATIONS
+
+There are no known bugs in this module
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head2 LICENSE AND COPYRIGHT
+
+Copyright (c) 2007, ClearSCM, Inc. All rights reserved.
+
+=cut
--- /dev/null
+=pod
+
+=head1 NAME $RCSfile: Vobs.pm,v $
+
+Object oriented interface to Clearcase VOBs
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.17 $
+
+=item Created
+
+Thu Dec 29 12:07:59 PST 2005
+
+=item Modified
+
+$Date: 2011/11/16 19:46:13 $
+
+=back
+
+=head1 SYNOPSIS
+
+Provides access to information about all Clearcase VOBs.
+
+ # Create VOBs object
+ my $vobs = new Clearcase::Vobs;
+
+ display "There are " . $vobs->vobs . " vobs to process";
+
+ # Iterrate through the list of vobs
+ foreach ($vobs->vobs) {
+ my $vob = new Clearcase::Vob $_;
+ ...
+ } # foreach
+
+ # VOBs manipulation
+ display "Umounting all vobs";
+
+ $vobs->umount;
+
+ display "Mounting all vobs";
+
+ $vobs->mount;
+
+=head1 DESCRIPTION
+
+This module implements a Clearcase vobs object to deal with the lists
+of vobs in the current region.
+
+=head1 ROUTINES
+
+The following routines are exported:
+
+=cut
+
+package Clearcase::Vobs;
+
+use strict;
+use warnings;
+
+use lib '..';
+
+use Clearcase;
+use Display;
+use OSDep;
+
+sub new () {
+ my ($class) = @_;
+
+=pod
+
+=head2 new (tag)
+
+Construct a new Clearcase Vobs object.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Clearcase VOBs object
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my ($status, @output) = $Clearcase::CC->execute ("lsvob -short");
+
+ return if $status;
+
+ # Strip $VOBTAG_PREFIX
+ foreach (@output) {
+ if ($ARCH eq 'windows' or $ARCH eq 'cygwin') {
+ s/\\//;
+ } else {
+ s/$Clearcase::VOBTAG_PREFIX//;
+ } # if
+ } # foreach
+
+ return bless {
+ vobs => \@output
+ }, $class; # bless
+} # new
+
+sub vobs () {
+ my ($self) = @_;
+
+=pod
+
+=head3 vobs
+
+Return a list of VOB tags in an array context or the number of vobs in
+a scalar context.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=over
+
+=item none
+
+=back
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=over
+
+=item List of VOBs or number of VOBs
+
+Array of VOB tags in an array context or the number of vobs in a scalar context.
+
+=back
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ if (wantarray) {
+ my @returnVobs = sort @{$self->{vobs}};
+
+ return @returnVobs;
+ } else {
+ return scalar @{$self->{vobs}};
+ } #if
+} # vobs
+
+sub mount () {
+ my ($self) = @_;
+
+=pod
+
+=head3 mount
+
+Mount all VOBs
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=over
+
+=item none
+
+=back
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=over
+
+=item $status
+
+Status from cleartool
+
+=item @output
+
+Ouput from cleartool
+
+=back
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my ($status, @output) = $Clearcase::CC->execute ("mount -all");
+
+ return $status;
+} # mount
+
+sub umount () {
+ my ($self) = @_;
+
+=pod
+
+=head3 umount
+
+Unmounts all VOBs
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=over
+
+=item none
+
+=back
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=over
+
+=item $status
+
+Status from cleartool
+
+=item @output
+
+Ouput from cleartool
+
+=back
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my ($status, @output) = $Clearcase::CC->execute ("umount -all");
+
+ return $status;
+} # umount
+
+1;
+
+=pod
+
+=head2 DEPENDENCIES
+
+=head3 ClearSCM Perl Modules
+
+=for html <p><a href="/php/cvs_man.php?file=lib/Clearcase.pm">Clearcase</a></p>
+
+=for html <p><a href="/php/cvs_man.php?file=lib/Display.pm">Display</a></p>
+
+=for html <p><a href="/php/cvs_man.php?file=lib/OSDep.pm">OSdep</a></p>
+
+=head2 BUGS AND LIMITATIONS
+
+There are no known bugs in this module
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head2 LICENSE AND COPYRIGHT
+
+Copyright (c) 2007, ClearSCM, Inc. All rights reserved.
+
+=cut
--- /dev/null
+=pod
+
+=head1 NAME $RCSfile: Clearquest.pm,v $
+
+Object oriented interface to Clearquest.
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 2.23 $
+
+=item Created
+
+Fri Sep 22 09:21:18 CDT 2006
+
+=item Modified
+
+$Date: 2013/03/28 22:48:07 $
+
+=back
+
+=head1 SYNOPSIS
+
+Provides access to Clearquest database in an object oriented manner.
+
+ # Create Clearquest object
+ my $cq = Clearquest->new;
+
+ # Connect to database (using all the defaults in cq.conf)
+ $cq->connect;
+
+ # Connect as non standard user;
+
+ $cq->connect (CQ_USERNAME => 'me', CQ_PASSWORD => 'mypassword');
+
+ # Get record (Default: all fields)
+ my %record = $cq->get ($recordName, $key);
+
+ # Get record with specific field list
+ my %record =$cq->get ($recordName, $key, qw(field1 field2))
+
+ # Modify a record
+ my %update = (
+ Description => 'This is a new description',
+ Active => 1,
+ );
+ $cq->modify ($recordName, $key, 'Modify', \%update);
+
+ # Change state using modify with an alternate action. Note the use of @ordering
+ my %fieldsToUpdate = (
+ Project => 'Carrier',
+ Category => 'New Functionality',
+ Groups => [ 'Group1', 'Group2' ],
+ );
+
+ my @ordering qw(Project Category);
+
+ $cq->modify ($recordName, $key, 'Open', \%fieldsToUpdate, @ordering);
+
+ if ($cq->error) {
+ error "Unable to update $key to Opened state\n"
+ . $cq->errmsg;
+ } # if
+
+=head1 DESCRIPTION
+
+This module provides a simple interface to Clearquest in a Perl like fashion.
+There are three modes of talking to Clearquest using this module - api, rest
+and client.
+
+With module = 'api' you must have Clearquest installed locally and you must use
+cqperl to execute your script. This mode of operation has the benefit of speed -
+note that initial connection to the Clearquest database is not very speedy, but
+all subsequent calls will operate at full speed. The 'api' module is free to
+use. For the other modules contact ClearSCM, Inc.
+
+With module = 'rest' you can access Clearquest by using a RESTFull interface.
+You can use any Perl which has the required CPAN modules (REST, XML::Simple -
+see Clearquest::REST for a list of required CPAN modules). The REST interface is
+a slower than the native api and requires the setup of Clearquest Web (cqweb) on
+your network. To use the REST interface set CQ_MODULE to 'rest'.
+
+With module = 'client' you access Clearquest through the companion
+Clearquest::Server module and the cqd.pl server script. The server process is
+started on a machine that has Clearquest installed locally. It uses the api
+interface for speed and can operate in a multithreaded manner, spawning
+processes which open and handle requests from Clearquest::Client requests. To
+use the Client interface set CQ_MODULE to 'client'.
+
+Other than setting CQ_MODULE to one of the three modes described above, the rest
+of your script's usage of the Clearquest module should be exactly the same.
+
+=head1 CONFIGURATION
+
+This module uses GetConfig to read in a configuration file (../etc/cq.conf)
+which sets default values described below. Or you can export the option name to
+the env(1) to override the defaults in cq.conf. Finally you can programmatically
+set the options when you call new by passing in a %parms hash. To specify the
+%parms hash key remove the CQ_ portion and lc the rest.
+
+=for html <blockquote>
+
+=over
+
+=item CQ_SERVER
+
+Clearquest server to talk to. Also used for rest server (Default: From cq.conf)
+
+=item CQ_PORT
+
+Port to connect to (Default: From cq.conf)
+
+=item CQ_WEBHOST
+
+The web host to contact with leading http:// (Default: From cq.conf)
+
+=item CQ_DATABASE
+
+Name of database to connect to (Default: From cq.conf)
+
+=item CQ_USERNAME
+
+User name to connect as (Default: From cq.conf)
+
+=item CQ_PASSWORD
+
+Password for CQREST_USERNAME (Default: From cq.conf)
+
+=item CQ_DBSET
+
+Database Set name (Default: From cq.conf)
+
+=item CQ_MODULE
+
+One of 'api', 'rest' or 'client' (Default: From cq.conf)
+
+=back
+
+=head1 METHODS
+
+The following methods are available:
+
+=cut
+
+package Clearquest;
+
+use strict;
+use warnings;
+
+use File::Basename;
+use Carp;
+use Time::Local;
+
+use GetConfig;
+
+# Seed options from config file
+my $config = $ENV{CQ_CONF} || dirname (__FILE__) . '/../etc/cq.conf';
+
+croak "Unable to find config file $config" unless -r $config;
+
+our %OPTS = GetConfig $config;
+
+my $DEFAULT_DBSET = $OPTS{CQ_DBSET};
+
+our $VERSION = '$Revision: 2.23 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+# Override options if in the environment
+$OPTS{CQ_DATABASE} = $ENV{CQ_DATABASE} if $ENV{CQ_DATABASE};
+$OPTS{CQ_DBSET} = $ENV{CQ_DBSET} if $ENV{CQ_DBSET};
+$OPTS{CQ_MODULE} = $ENV{CQ_MODULE} if $ENV{CQ_MODULE};
+$OPTS{CQ_PASSWORD} = $ENV{CQ_PASSWORD} if $ENV{CQ_PASSWORD};
+$OPTS{CQ_PORT} = $ENV{CQ_PORT} if $ENV{CQ_PORT};
+$OPTS{CQ_SERVER} = $ENV{CQ_SERVER} if $ENV{CQ_SERVER};
+$OPTS{CQ_USERNAME} = $ENV{CQ_USERNAME} if $ENV{CQ_USERNAME};
+
+# FieldTypes ENUM
+our $UNKNOWN = -1;
+our $STRING = 1;
+our $MULTILINE_STRING = 2;
+our $INT = 3;
+our $DATE_TIME = 4;
+our $REFERENCE = 5;
+our $REFERENCE_LIST = 6;
+our $ATTACHMENT_LIST = 7;
+our $ID = 8;
+our $STATE = 9;
+our $JOURNAL = 10;
+our $DBID = 11;
+our $STATETYPE = 12;
+our $RECORD_TYPE = 13;
+
+my %FIELDS;
+
+my @objects;
+
+my $SECS_IN_MIN = 60;
+my $SECS_IN_HOUR = $SECS_IN_MIN * 60;
+my $SECS_IN_DAY = $SECS_IN_HOUR * 24;
+
+my $operatorRE = qr/
+ (\w+) # field name
+ \s* # whitespace
+ ( # operators
+ == # double equals
+ |= # single equals
+ |!= # not equal
+ |<> # the other not equal
+ |<= # less than or equal
+ |>= # greater than or equal
+ |< # less than
+ |> # greater than
+ |like # like
+ |not\s+like # not like
+ |between # between
+ |not\s*between # not between
+ |is\s+null # is null
+ |is\s+not\s+null # is not null
+ |in # in
+ |not\s+in # not in
+ )
+ \s* # whitespace
+ (.*) # value
+ /ix;
+
+END {
+ # Insure all instaniated objects have been destroyed
+ $_->DESTROY foreach (@objects);
+} # END
+
+# Internal methods
+sub _commitRecord ($) {
+ my ($self, $entity) = @_;
+
+ $self->{errmsg} = $entity->Validate;
+
+ if ($self->{errmsg} eq '') {
+ $self->{errmsg} = $entity->Commit;
+ $self->{error} = $self->{errmsg} eq '' ? 0 : 1;
+
+ return $self->{errmsg};
+ } else {
+ $self->{error} = 1;
+
+ $entity->Revert;
+
+ return $self->{errmsg};
+ } # if
+} # _commitRecord
+
+sub _is_leap_year ($) {
+ my ($year) = @_;
+
+ return 0 if $year % 4;
+ return 1 if $year % 100;
+ return 0 if $year % 400;
+
+ return 1;
+} # _is_leap_year
+
+sub _dateToEpoch ($) {
+ my ($date) = @_;
+
+ my $year = substr $date, 0, 4;
+ my $month = substr $date, 5, 2;
+ my $day = substr $date, 8, 2;
+ my $hour = substr $date, 11, 2;
+ my $minute = substr $date, 14, 2;
+ my $seconds = substr $date, 17, 2;
+
+ my $days;
+
+ for (my $i = 1970; $i < $year; $i++) {
+ $days += _is_leap_year ($i) ? 366 : 365;
+ } # for
+
+ my @monthDays = (
+ 0,
+ 31,
+ 59,
+ 90,
+ 120,
+ 151,
+ 181,
+ 212,
+ 243,
+ 273,
+ 304,
+ 334,
+ );
+
+ $days += $monthDays[$month - 1];
+
+ $days++
+ if _is_leap_year ($year) and $month > 2;
+
+ $days += $day - 1;
+
+ return ($days * $SECS_IN_DAY)
+ + ($hour * $SECS_IN_HOUR)
+ + ($minute * $SECS_IN_MIN)
+ + $seconds;
+} # _dateToEpoch
+
+sub _epochToDate ($) {
+ my ($epoch) = @_;
+
+ my $year = 1970;
+ my ($month, $day, $hour, $minute, $seconds);
+ my $leapYearSecs = 366 * $SECS_IN_DAY;
+ my $yearSecs = $leapYearSecs - $SECS_IN_DAY;
+
+ while () {
+ my $amount = _is_leap_year ($year) ? $leapYearSecs : $yearSecs;
+
+ last
+ if $amount > $epoch;
+
+ $epoch -= $amount;
+ $year++;
+ } # while
+
+ my $leapYearAdjustment = _is_leap_year ($year) ? 1 : 0;
+
+ if ($epoch >= (334 + $leapYearAdjustment) * $SECS_IN_DAY) {
+ $month = '12';
+ $epoch -= (334 + $leapYearAdjustment) * $SECS_IN_DAY;
+ } elsif ($epoch >= (304 + $leapYearAdjustment) * $SECS_IN_DAY) {
+ $month = '11';
+ $epoch -= (304 + $leapYearAdjustment) * $SECS_IN_DAY;
+ } elsif ($epoch >= (273 + $leapYearAdjustment) * $SECS_IN_DAY) {
+ $month = '10';
+ $epoch -= (273 + $leapYearAdjustment) * $SECS_IN_DAY;
+ } elsif ($epoch >= (243 + $leapYearAdjustment) * $SECS_IN_DAY) {
+ $month = '09';
+ $epoch -= (243 + $leapYearAdjustment) * $SECS_IN_DAY;
+ } elsif ($epoch >= (212 + $leapYearAdjustment) * $SECS_IN_DAY) {
+ $month = '08';
+ $epoch -= (212 + $leapYearAdjustment) * $SECS_IN_DAY;
+ } elsif ($epoch >= (181 + $leapYearAdjustment) * $SECS_IN_DAY) {
+ $month = '07';
+ $epoch -= (181 + $leapYearAdjustment) * $SECS_IN_DAY;
+ } elsif ($epoch >= (151 + $leapYearAdjustment) * $SECS_IN_DAY) {
+ $month = '06';
+ $epoch -= (151 + $leapYearAdjustment) * $SECS_IN_DAY;
+ } elsif ($epoch >= (120 + $leapYearAdjustment) * $SECS_IN_DAY) {
+ $month = '05';
+ $epoch -= (120 + $leapYearAdjustment) * $SECS_IN_DAY;
+ } elsif ($epoch >= (90 + $leapYearAdjustment) * $SECS_IN_DAY) {
+ $month = '04';
+ $epoch -= (90 + $leapYearAdjustment) * $SECS_IN_DAY;
+ } elsif ($epoch >= (59 + $leapYearAdjustment) * $SECS_IN_DAY) {
+ $month = '03';
+ $epoch -= (59 + $leapYearAdjustment) * $SECS_IN_DAY;
+ } elsif ($epoch >= 31 * $SECS_IN_DAY) {
+ $month = '02';
+ $epoch -= 31 * $SECS_IN_DAY;
+ } else {
+ $month = '01';
+ } # if
+
+ $day = int (($epoch / $SECS_IN_DAY) + 1);
+ $epoch = $epoch % $SECS_IN_DAY;
+ $hour = int ($epoch / $SECS_IN_HOUR);
+ $epoch = $epoch % $SECS_IN_HOUR;
+ $minute = int ($epoch / $SECS_IN_MIN);
+ $seconds = $epoch % $SECS_IN_MIN;
+
+ $day = "0$day" if $day < 10;
+ $hour = "0$hour" if $hour < 10;
+ $minute = "0$minute" if $minute < 10;
+ $seconds = "0$seconds" if $seconds < 10;
+
+ return "$year-$month-$day $hour:$minute:$seconds";
+} # _pochToDate
+
+sub _parseCondition ($) {
+ my ($self, $condition) = @_;
+
+ # Parse simple conditions only
+ my ($field, $operator, $value);
+
+ if ($condition =~ $operatorRE) {
+ $field = $1;
+ $operator = $2;
+ $value = $3;
+
+ if ($operator eq '==' or $operator eq '=') {
+ if ($value !~ /^null$/i) {
+ $operator = $CQPerlExt::CQ_COMP_OP_EQ;
+ } else {
+ $operator = $CQPerlExt::CQ_COMP_OP_IS_NULL;
+ } # if
+ } elsif ($operator eq '!=' or $operator eq '<>') {
+ if ($value !~ /^null$/i) {
+ $operator = $CQPerlExt::CQ_COMP_OP_NEQ;
+ } else {
+ $operator = $CQPerlExt::CQ_COMP_OP_IS_NOT_NULL;
+ } # if
+ } elsif ($operator eq '<') {
+ $operator = $CQPerlExt::CQ_COMP_OP_LT;
+ } elsif ($operator eq '>') {
+ $operator = $CQPerlExt::CQ_COMP_OP_GT;
+ } elsif ($operator eq '<=') {
+ $operator = $CQPerlExt::CQ_COMP_OP_LTE;
+ } elsif ($operator eq '>=') {
+ $operator = $CQPerlExt::CQ_COMP_OP_GTE;
+ } elsif ($operator =~ /^like$/i) {
+ $operator = $CQPerlExt::CQ_COMP_OP_LIKE;
+ } elsif ($operator =~ /^not\s+like$/i) {
+ $operator = $CQPerlExt::CQ_COMP_OP_NOT_LIKE;
+ } elsif ($operator =~ /^between$/i) {
+ $operator = $CQPerlExt::CQ_COMP_OP_BETWEEN;
+ } elsif ($operator =~ /^not\s+between$/i) {
+ $operator = $CQPerlExt::CQ_COMP_OP_NOT_BETWEEN;
+ } elsif ($operator =~ /^is\s+null$/i) {
+ $operator = $CQPerlExt::CQ_COMP_OP_IS_NULL;
+ } elsif ($operator =~ /^is\s+not\s+null$/i) {
+ $operator = $CQPerlExt::CQ_COMP_OP_IS_NOT_NULL;
+ } elsif ($operator =~ /^in$/i) {
+ $operator = $CQPerlExt::CQ_COMP_OP_IN;
+ } elsif ($operator =~ /^not\s+in$/) {
+ $operator = $CQPerlExt::CQ_COMP_OP_NOT_IN;
+ } else {
+ $self->_setError ("I can't understand the operator $operator");
+
+ $operator = undef;
+
+ return 1;
+ } # if
+ } else {
+ # TODO: How to handle more complicated $condition....
+ $self->_setError ("I can't understand the conditional expression "
+ . $condition);
+
+ $operator = undef;
+
+ return 1;
+ } # if
+
+ # Trim quotes if any:
+ if ($value =~ /^\s*\'/) {
+ $value =~ s/^\s*\'//;
+ $value =~ s/\'\s*$//;
+ } elsif ($value =~ /^\s*\"/) {
+ $value =~ s/^\s*\"//;
+ $value =~ s/\"\s*$//;
+ } # if
+
+ # Trim leading and trailing whitespace
+ $value =~ s/^\s+//;
+ $value =~ s/\s+$//;
+
+ return ($field, $operator, $value);
+} # _parseCondition
+
+sub _parseConditional ($$;$);
+sub _parseConditional ($$;$) {
+ my ($self, $query, $condition, $filterOperator) = @_;
+
+ return if $condition eq '';
+
+ my ($field, $operator, $value);
+
+ if ($condition =~ /(.+?)\s+(and|or)\s+(.+)/i) {
+ my $leftSide = $1;
+ my $conjunction = lc $2;
+ my $rightSide = $3;
+
+ if ($conjunction eq 'and') {
+ unless ($filterOperator) {
+ $filterOperator = $query->BuildFilterOperator ($CQPerlExt::CQ_BOOL_OP_AND);
+ } else {
+ $filterOperator = $filterOperator->BuildFilterOperator ($CQPerlExt::CQ_BOOL_OP_AND);
+ } # unless
+ } elsif ($conjunction eq 'or') {
+ unless ($filterOperator) {
+ $filterOperator = $query->BuildFilterOperator ($CQPerlExt::CQ_BOOL_OP_OR);
+ } else {
+ $filterOperator = $filterOperator->BuildFilterOperator ($CQPerlExt::CQ_BOOL_OP_OR);
+ } # unless
+ } # if
+
+ $self->_setCondition ($self->_parseCondition ($leftSide), $filterOperator);
+
+ $self->_parseConditional ($query, $rightSide, $filterOperator);
+ } else {
+ unless ($condition =~ $operatorRE) {
+ $self->_setError ("Unable to parse condition \"$condition\"");
+
+ return;
+ } # unless
+
+ $filterOperator = $query->BuildFilterOperator ($CQPerlExt::CQ_BOOL_OP_AND)
+ unless $filterOperator;
+
+ $self->_setCondition ($self->_parseCondition ($condition), $filterOperator);
+ } # if
+
+ # Actually clear error...
+ $self->_setError;
+
+ return;
+} # _parseConditional
+
+sub _setCondition ($$$) {
+ my ($self, $field, $operator, $value, $filterOperator) = @_;
+
+ return unless $operator;
+
+ if ($operator == $CQPerlExt::CQ_COMP_OP_IS_NULL or
+ $operator == $CQPerlExt::CQ_COMP_OP_IS_NOT_NULL) {
+ eval {$filterOperator->BuildFilter ($field, $operator, [()])};
+
+ if ($@) {
+ $self->_setError ($@);
+
+ carp $@;
+ } # if
+ } else {
+ # If the operator is one of the operators that have mulitple values then we
+ # need to make an array of $value
+ if ($operator == $CQPerlExt::CQ_COMP_OP_BETWEEN or
+ $operator == $CQPerlExt::CQ_COMP_OP_NOT_BETWEEN or
+ $operator == $CQPerlExt::CQ_COMP_OP_IN or
+ $operator == $CQPerlExt::CQ_COMP_OP_NOT_IN) {
+ my @values = split /,\s*/, $value;
+
+ eval {$filterOperator->BuildFilter ($field, $operator, \@values)};
+
+ if ($@) {
+ $self->_setError ($@);
+
+ carp $@;
+ } # if
+ } else {
+ eval {$filterOperator->BuildFilter ($field, $operator, [$value])};
+
+ if ($@) {
+ $self->_setError ($@);
+
+ carp $@;
+ } # if
+ } # if
+ } # if
+
+ return;
+} # _setCondition
+
+sub _setFields ($@) {
+ my ($self, $table, @fields) = @_;
+
+ my $entityDef;
+
+ eval {$entityDef = $self->{session}->GetEntityDef ($table)};
+
+ if ($@) {
+ $self->_setError ($@, -1);
+
+ return;
+ } # if
+
+ unless (@fields) {
+ # Always return dbid
+ push @fields, 'dbid' unless grep {$_ eq 'dbid'} @fields;
+
+ foreach (@{$entityDef->GetFieldDefNames}) {
+ unless ($self->{returnSystemFields}) {
+ next if $entityDef->IsSystemOwnedFieldDefName ($_);
+ } # unless
+
+ push @fields, $_;
+ } # foreach
+ } # unless
+
+ return @fields;
+} # _setFields
+
+sub _setError (;$$) {
+ my ($self, $errmsg, $error) = @_;
+
+ $error ||= 0;
+
+ if ($errmsg and $errmsg ne '') {
+ $error = 1;
+
+ $self->{errmsg} = $errmsg;
+ } else {
+ $self->{errmsg} = '';
+ } # if
+
+ $self->error ($error);
+
+ return;
+} # _setError
+
+sub _setFieldValue ($$$$) {
+ my ($self, $entity, $table, $fieldName, $fieldValue) = @_;
+
+ my $errmsg = '';
+
+ my $entityDef = $self->{session}->GetEntityDef ($table);
+
+ return $errmsg if $entityDef->IsSystemOwnedFieldDefName ($fieldName);
+
+ unless (ref $fieldValue eq 'ARRAY') {
+ # This is one of those rare instances where it is important to surround a
+ # bare variable with double quotes otherwise the CQ API will wrongly
+ # evaluate $fieldValue if $fieldValue is a simple number (e.g. 0, 1, etc.)
+ $errmsg = $entity->SetFieldValue ($fieldName, "$fieldValue") if $fieldValue;
+ } else {
+ foreach (@$fieldValue) {
+ $errmsg = $entity->AddFieldValue ($fieldName, $_);
+
+ return $errmsg unless $errmsg eq '';
+ } # foreach
+ } # unless
+
+ return $errmsg;
+} # _setFieldValues
+
+sub _UTCTime ($) {
+ my ($datetime) = @_;
+
+ my @localtime = localtime;
+ my ($sec, $min, $hour, $mday, $mon, $year) = gmtime (
+ _dateToEpoch ($datetime) - (timegm (@localtime) - timelocal (@localtime))
+ );
+
+ $year += 1900;
+ $mon++;
+
+ $sec = '0' . $sec if $sec < 10;
+ $min = '0' . $min if $min < 10;
+ $hour = '0' . $hour if $hour < 10;
+ $mon = '0' . $mon if $mon < 10;
+ $mday = '0' . $mday if $mday < 10;
+
+ return "$year-$mon-${mday}T$hour:$min:${sec}Z";
+} # _UTCTime
+
+sub _UTC2Localtime ($) {
+ my ($utcdatetime) = @_;
+
+ return unless $utcdatetime;
+
+ # If the field does not look like a UTC time then just return it.
+ return $utcdatetime unless $utcdatetime =~ /\d{4}-\d{2}-\d{2}T\d{2}:\d{2}:\d{2}Z/;
+
+ $utcdatetime =~ s/T/ /;
+ $utcdatetime =~ s/Z//;
+
+ my @localtime = localtime;
+
+ return _epochToDate (
+ _dateToEpoch ($utcdatetime) + (timegm (@localtime) - timelocal (@localtime))
+ );
+} # _UTC2Localtime
+
+sub add ($$;@) {
+ my ($self, $table, $values, @ordering) = @_;
+
+=pod
+
+=head2 add ($$;@)
+
+Insert a new record into the database
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $table
+
+The name of the table to insert into
+
+=item $values
+
+Hash reference of name/value pairs for the insertion
+
+=item @ordering
+
+Array containing field names that need to be processed in order. Not all fields
+mentioned in the $values hash need be mentioned here. If you have fields that
+must be set in a particular order you can mention them here. So, if you're
+adding the Defect record, but you need Project set before Platform, you need
+only pass in an @ordering of qw(Project Platform). They will be done first, then
+all of the rest of the fields in the $values hash. If you have no ordering
+dependencies then you can simply omit @ordering.
+
+Note that the best way to determine if you have an ordering dependency try using
+a Clearquest client and note the order that you set fields in. If at anytime
+setting one field negates another field via action hook code then you have just
+figured out that this field needs to be set before the file that just got
+negated.
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $dbid
+
+The DBID of the newly added record or undef if error.
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $self->{errmsg} = '';
+
+ unless ($self->connected) {
+ $self->_setError ('You must connect to Clearquest before you can call add');
+
+ return;
+ } # unless
+
+ my %values = %$values;
+ my $entity;
+
+ eval {$entity = $self->{session}->BuildEntity ($table)};
+
+ if ($@) {
+ $self->_setError ("Unable to create new $table record:\n$@");
+
+ return;
+ } # if
+
+ # First process all fields in @ordering, if specified
+ foreach (@ordering) {
+ if ($values{$_}) {
+ $self->{errmsg} = $self->_setFieldValue ($entity, $table, $_, $values{$_});
+ } else {
+ $self->_setError ("$_ from the ordering array is not present in the value hash", -1);
+ } # if
+
+ last unless $self->{errmsg} eq '';
+ } # foreach
+
+ return unless $self->{errmsg} eq '';
+
+ # Now process the rest of the values
+ foreach my $fieldName (keys %values) {
+ next if grep {$fieldName eq $_} @ordering;
+
+ $self->{errmsg} = $self->_setFieldValue ($entity, $table, $fieldName, $values{$fieldName});
+
+ last unless $self->{errmsg} eq '';
+ } # foreach
+
+ $self->_setError ($self->{errmsg});
+
+ return unless $self->{errmsg} eq '';
+
+ $self->{errmsg} = $self->_commitRecord ($entity);
+ $self->{error} = $self->{errmsg} eq '' ? 0 : 1;
+
+ my $dbid = $entity->GetFieldValue ('dbid')->GetValue;
+
+ return $dbid;
+} # add
+
+sub connect (;$$$$) {
+ my ($self, $username, $password, $database, $dbset) = @_;
+
+=pod
+
+=head2 connect (;$$$$)
+
+Connect to the Clearquest database. You can supply parameters such as username,
+password, etc and they will override any passed to Clearquest::new (or those
+coming from ../etc/cq.conf)
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $username
+
+Username to use to connect to the database
+
+=item $password
+
+Password to use to connect to the database
+
+=item $database
+
+Clearquest database to connect to
+
+=item $dbset
+
+Database set to connect to (Default: Connect to the default dbset)
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item 1
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return unless $self->{module} eq 'api';
+
+ eval {require CQPerlExt};
+
+ croak "Unable to use Rational's CQPerlExt library - "
+ . "You must use cqperl to use the Clearquest API back end\n$@" if $@;
+
+ $self->{username} = $username if $username;
+ $self->{password} = $password if $password;
+ $self->{database} = $database if $database;
+ $self->{dbset} = $dbset if $dbset;
+
+ $self->{session} = CQSession::Build ();
+
+ $self->{loggedin} = 0;
+
+ eval {
+ $self->{session}->UserLogon ($self->{username},
+ $self->{password},
+ $self->{database},
+ $self->{dbset});
+ };
+
+ if ($@) {
+ chomp ($@);
+
+ $self->_setError ($@, 1);
+ } else {
+ $self->{loggedin} = 1;
+
+ $self->_setError ($_, 0);
+ } # if
+
+ return $self->{loggedin};
+} # connect
+
+sub connected () {
+ my ($self) = @_;
+
+=pod
+
+=head2 connected ()
+
+Returns 1 if we are currently connected to Clearquest
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item 1 if logged in - 0 if not
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{loggedin};
+} # connected
+
+sub connection ($) {
+ my ($self, $fullyQualify) = @_;
+
+=pod
+
+=head2 connection ()
+
+Returns a connection string that describes the current connection
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $fullyQualify
+
+If true the connection string will be fully qualified
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $connectionStr
+
+A string describing the current connection. Generally
+<username>@<database>[/<dbset>]. Note that <dbset> is only displayed if it is
+not the default DBSet as defined in cq.conf.
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my $connectionStr = $self->username ()
+ . '@'
+ . $self->database ();
+
+ if ($fullyQualify) {
+ $connectionStr .= '/' . $self->dbset;
+ } else {
+ $connectionStr .= '/' . $self->dbset () unless $self->dbset eq $DEFAULT_DBSET;
+ } # if
+
+ return $connectionStr;
+} # connection
+
+sub checkErr (;$$) {
+ my ($self, $msg, $die) = @_;
+
+=pod
+
+=head2 checkErr (;$$)
+
+Checks for error in the last Clearquest method call and prints error to STDERR.
+Optionally prints a user message if $msg is specified. Dies if $die is true
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $msg
+
+User error message
+
+=item $die
+
+Causes caller to croak if set to true
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $error
+
+Returns 0 for no error, non-zero if error.
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $die ||= 0;
+
+ if ($self->{error}) {
+ if ($msg) {
+ $msg .= "\n" . $self->errmsg . "\n";
+ } else {
+ $msg = $self->errmsg . "\n";
+ } # if
+
+ if ($die) {
+ croak $msg if $die;
+ } else {
+ print STDERR "$msg\n";
+
+ return $self->{error};
+ } # if
+ } # if
+
+ return 0;
+} # checkErr
+
+sub database () {
+ my ($self) = @_;
+
+=pod
+
+=head2 database
+
+Returns the current database (or the database that would be used)
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item database
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{database};
+} # database
+
+sub dbset () {
+ my ($self) = @_;
+
+=pod
+
+=head2 dbset
+
+Returns the current dbset (or the dbset that would be used)
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item dbset
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{dbset};
+} # dbset
+
+sub dbsets () {
+ my ($self) = @_;
+
+=pod
+
+=head2 dbsets ()
+
+Return the installed DBSets for this schema
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item @dbsets
+
+An array of dbsets
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ unless ($self->connected) {
+ $self->_setError ('You must connect to Clearquest before you can call DBSets', '-1');
+
+ return;
+ } # unless
+
+ return @{$self->{session}->GetInstalledDbSets};
+} # dbsets
+
+sub delete ($;$) {
+ my ($self, $table, $key) = @_;
+
+=pod
+
+=head2 delete ($;$)
+
+Deletes records from the database
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $table
+
+Table to delete records from
+
+=item $key
+
+Key of the record to delete
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $errmsg
+
+Error message or blank if no error
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my $entity;
+
+ eval {$entity = $self->{session}->GetEntity ($table, $key)};
+
+ if ($@) {
+ $self->_setError ($@, 1);
+
+ return $@;
+ } # if
+
+ eval {$self->{session}->DeleteEntity ($entity, 'Delete')};
+
+ if ($@) {
+ $self->_setError ($@, 1);
+
+ return $@;
+ } # if
+
+ return '';
+} # delete
+
+sub DESTROY () {
+ my ($self) = @_;
+
+ CQSession::Unbuild ($self->{session}) if $self->{session};
+
+ return;
+} # DESTROY
+
+sub disconnect () {
+ my ($self) = @_;
+
+=pod
+
+=head2 disconnect ()
+
+Disconnect from Clearquest
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item nothing
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ CQSession::Unbuild ($self->{session});
+
+ undef $self->{session};
+
+ $self->{loggedin} = 0;
+
+ return;
+} # disconnect
+
+sub errmsg (;$) {
+ my ($self, $errmsg) = @_;
+
+=pod
+
+=head2 errmsg ()
+
+Returns the last error message. Optionally sets the error message if specified.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $errmsg
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $errmsg
+
+Last $errmsg
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $self->{errmsg} = $errmsg if $errmsg;
+
+ return $self->{errmsg};
+} # errmsg
+
+sub error (;$) {
+ my ($self, $error) = @_;
+
+=pod
+
+=head2 error ($error)
+
+Returns the last error number. Optional set the error number if specified
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $error
+
+Error number to set
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $error
+
+Last error
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $self->{error} = $error if defined $error;
+
+ return $self->{error};
+} # error
+
+sub fieldType ($$) {
+ my ($self, $table, $fieldName) = @_;
+
+=pod
+
+=head2 fieldType ($table, $fieldname)
+
+Returns the field type for the $table, $fieldname combination.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $table
+
+Table to return field type from.
+
+=item $fieldname
+
+Fieldname to return the field type from.
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $fieldType
+
+Fieldtype enum
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $UNKNOWN unless $self->{loggedin};
+
+ # If we've already computed the fieldTypes for the fields in this table then
+ # return the value
+ if ($FIELDS{$table}) {
+ # If we already have this fieldType just return it
+ if (defined $FIELDS{$table}{$fieldName}) {
+ return $FIELDS{$table}{$fieldName}
+ } else {
+ return $UNKNOWN
+ } # if
+ } # if
+
+ my $entityDef = $self->{session}->GetEntityDef ($table);
+
+ foreach (@{$entityDef->GetFieldDefNames}) {
+ $FIELDS{$table}{$_} = $entityDef->GetFieldDefType ($_);
+ } # foreach
+
+ if (defined $FIELDS{$table}{$fieldName}) {
+ return $FIELDS{$table}{$fieldName}
+ } else {
+ return $UNKNOWN
+ } # if
+} # fieldType
+
+sub fieldTypeName ($$) {
+ my ($self, $table, $fieldName) = @_;
+
+=pod
+
+=head2 fieldTypeName ($table, $fieldname)
+
+Returns the field type name for the $table, $fieldname combination.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $table
+
+Table to return field type from.
+
+=item $fieldname
+
+Fieldname to return the field type from.
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $fieldTypeName
+
+Fieldtype name
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my $fieldType = $self->fieldType ($table, $fieldName);
+
+ return $UNKNOWN unless $fieldType;
+
+ if ($fieldType == $STRING) {
+ return "STRING";
+ } elsif ($fieldType == $MULTILINE_STRING) {
+ return "MULTILINE_STRING";
+ } elsif ($fieldType == $INT) {
+ return "INT";
+ } elsif ($fieldType == $DATE_TIME) {
+ return "DATE_TIME";
+ } elsif ($fieldType == $REFERENCE) {
+ return "REFERENCE"
+ } elsif ($fieldType == $REFERENCE_LIST) {
+ return "REFERENCE_LIST";
+ } elsif ($fieldType == $ATTACHMENT_LIST) {
+ return "ATTACHMENT_LIST";
+ } elsif ($fieldType == $ID) {
+ return "ID";
+ } elsif ($fieldType == $STATE) {
+ return "STATE";
+ } elsif ($fieldType == $JOURNAL) {
+ return "JOURNAL";
+ } elsif ($fieldType == $DBID) {
+ return "DBID";
+ } elsif ($fieldType == $STATETYPE) {
+ return "STATETYPE";
+ } elsif ($fieldType == $RECORD_TYPE) {
+ return "RECORD_TYPE";
+ } elsif ($fieldType == $UNKNOWN) {
+ return "UNKNOWN";
+ } # if
+} # fieldTypeName
+
+sub find ($;$@) {
+ my ($self, $table, $condition, @fields) = @_;
+
+=pod
+
+=head2 find ($;$@)
+
+Find records in $table. You can specify a $condition and which fields you wish
+to retrieve. Specifying a smaller set of fields means less data transfered and
+quicker retrieval so only retrieve the fields you really need.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $table
+
+Name of the table to search
+
+=item $condition
+
+Condition to use. If you want all records then pass in undef. Only simple
+conditions are supported. You can specify compound conditions (e.g. field1 ==
+'foo' and field1 == 'bar' or field2 is not null). No parenthesizing is
+supported (yet).
+
+The following conditionals are supported
+
+=over
+
+=item Equal (==|=)
+
+=item Not Equal (!=|<>)
+
+=item Less than (<)
+
+=item Greater than (>)
+
+=item Less than or equal (<=)
+
+=item Greater than or equal (>=)
+
+=item Like
+
+=item Is null
+
+=item Is not null
+
+=item In
+
+=back
+
+Note that "is not null" is currently not working in the REST module (it works
+in the api and thus also in the client/server model). This because the
+OLSC spec V1.0 does not support it.
+
+As for "Like"", you'll need to specify "<fieldname> like '%var%'" for the
+condition.
+
+"In" is only available in the REST interface as that's what OLSC supports. It's
+syntax would be "<fieldname> In 'value1', 'value2', 'value3'..."
+
+Also conditions can be combined with (and|or) so in the api you could do "in"
+as "<fieldname> = 'value1 or <fieldname> = 'value2" or <fieldname> = 'value3'".
+
+Complicated expressions with parenthesis like "(Project = 'Athena' or Project =
+'Hawaii') and Category = 'Aspen'" are not supported.
+
+=item @fields
+
+An array of fieldnames to retrieve
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $result or ($result, $nbrRecs)
+
+Internal structure to be used with getNext. If in an array context then $nbrRecs
+is also returned.
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $condition ||= '';
+
+ unless ($self->connected) {
+ $self->_setError ('You must connect to Clearquest before you can call find', '-1');
+
+ return;
+ } # unless
+
+ my $entityDef;
+
+ eval {$entityDef = $self->{session}->GetEntityDef ($table)};
+
+ if ($@) {
+ $self->_setError ($@, -1);
+
+ return ($@, -1);
+ } # if
+
+ @fields = $self->_setFields ($table, @fields);
+
+ return unless @fields;
+
+ my $query = $self->{session}->BuildQuery ($table);
+
+ foreach (@fields) {
+ eval {$query->BuildField ($_)};
+
+ if ($@) {
+ $self->_setError ($@);
+
+ carp $@;
+ } # if
+ } # foreach
+
+ $self->_parseConditional ($query, $condition);
+
+ return if $self->error;
+
+ my $result = $self->{session}->BuildResultSet ($query);
+ my $nbrRecs = $result->ExecuteAndCountRecords;
+
+ $self->_setError;
+
+ my %resultSet = (
+ result => $result
+ );
+
+ if (wantarray) {
+ return (\%resultSet, $nbrRecs);
+ } else {
+ return \%resultSet
+ } # if
+} # find
+
+sub findIDs ($) {
+ my ($str) = @_;
+
+=pod
+
+=head2 findIDs ($)
+
+Given a $str or a reference to an array of strings, this function returns a list
+of Clearquest IDs found in the $str. If called in a scalar context this function
+returns a comma separated string of IDs found. Note that duplicate IDs are
+eliminated. Also, the lists of IDs may refer to different Clearquest databases.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $str
+
+String or reference to an array of strings to search
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item @IDs or $strIDs
+
+Either an array of CQ IDs or a comma separated list of CQ IDs.
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $str = join ' ', @$str if ref $str eq 'ARRAY';
+
+ my @IDs = $str =~ /([A-Za-z]\w{1,4}\d{8})/gs;
+
+ my %IDs;
+
+ map { $IDs{$_} = 1; } @IDs;
+
+ if (wantarray) {
+ return keys %IDs;
+ } else {
+ return join ',', keys %IDs;
+ } # if
+} # findIDs
+
+sub get ($$;@) {
+ my ($self, $table, $id, @fields) = @_;
+
+=pod
+
+=head2 get ($$)
+
+Return a record that you have the id or key of.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $table
+
+The $table to get the record from
+
+=item $id
+
+The $id or key to use to retrieve the record
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item %record
+
+Hash of name/value pairs for all the fields in $table
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ unless ($self->connected) {
+ $self->_setError ('You must connect to Clearquest before you can call get', '-1');
+
+ return;
+ } # unless
+
+ @fields = $self->_setFields ($table, @fields);
+
+ return unless @fields;
+
+ my $entity;
+
+ eval {$entity = $self->{session}->GetEntity ($table, $id)};
+
+ if ($@) {
+ $self->_setError ($@);
+
+ return;
+ } # if
+
+ my %record;
+
+ foreach (@fields) {
+ my $fieldType = $entity->GetFieldValue ($_)->GetType;
+
+ if ($fieldType == $CQPerlExt::CQ_REFERENCE_LIST) {
+ $record{$_} = $entity->GetFieldValue ($_)->GetValueAsList;
+ } else {
+ $record{$_} = $entity->GetFieldValue ($_)->GetValue;
+ $record{$_} ||= '' if $self->{emptyStringForUndef};
+
+ # Fix any UTC dates
+ if ($fieldType == $CQPerlExt::CQ_DATE_TIME) {
+ $record{$_} = _UTC2Localtime ($record{$_});
+ } # if
+ } # if
+ } # foreach
+
+ $self->_setError;
+
+ return %record;
+} # get
+
+sub getDBID ($$;@) {
+ my ($self, $table, $dbid, @fields) = @_;
+
+=pod
+
+=head2 getDBID ($$;@)
+
+Return a record that you have the dbid
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $table
+
+The $table to get the record from
+
+=item $dbid
+
+The $dbid to use to retrieve the record
+
+=item @fields
+
+Array of field names to retrieve (Default: All fields)
+
+Note: Avoid getting all fields for large records. It will be slow and bloat your
+script's memory usage.
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item %record
+
+Hash of name/value pairs for all the fields in $table
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ unless ($self->connected) {
+ $self->_setError ('You must connect to Clearquest before you can call getDBID', '-1');
+
+ return;
+ } # unless
+
+ @fields = $self->_setFields ($table, @fields);
+
+ return if @fields;
+
+ my $entity;
+
+ eval {$entity = $self->{session}->GetEntityByDbId ($table, $dbid)};
+
+ if ($@) {
+ $self->_setError ($@);
+
+ return;
+ } # if
+
+ my %record;
+
+ foreach (@fields) {
+ my $fieldType = $entity->GetFieldValue ($_)->GetType;
+
+ if ($fieldType == $CQPerlExt::CQ_REFERENCE_LIST) {
+ $record{$_} = $entity->GetFieldValue ($_)->GetValueAsList;
+ } else {
+ $record{$_} = $entity->GetFieldValue ($_)->GetValue;
+ $record{$_} ||= '' if $self->{emptyStringForUndef};
+
+ # Fix any UTC dates
+ if ($fieldType == $CQPerlExt::CQ_DATE_TIME) {
+ $record{$_} = _UTC2Localtime ($record{$_});
+ } # if
+ } # if
+ } # foreach
+
+ $self->_setError;
+
+ return %record;
+} # getDBID
+
+sub getDynamicList ($) {
+ my ($self, $list) = @_;
+
+=pod
+
+=head2 getDynamicList ($)
+
+Return the entries of a dynamic list
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $list
+
+The name of the dynamic list
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item @entries
+
+An array of entries from the dynamic list
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return () unless $self->connected;
+
+ return @{$self->{session}->GetListMembers ($list)};
+} # getDynamicList
+
+sub getNext ($) {
+ my ($self, $result) = @_;
+
+=pod
+
+=head2 getNext ($)
+
+Return the next record that qualifies from a preceeding call to the find method.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $result
+
+The $result returned from find.
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item %record
+
+Hash of name/value pairs for the @fields specified to find.
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ unless ($self->connected) {
+ $self->_setError ('You must connect to Clearquest before you can call getNext', '-1');
+
+ return;
+ } # unless
+
+# Here we need to do special processing to gather up reference list fields, if
+# any. If we have a reference list field in the field list then Clearquest
+# returns multiple records - one for each entry in the reference list. Thus if
+# you were getting say the key field of a record and a reference list field like
+# say Projects, you might see:
+#
+# Key Value Projects
+# --------- --------
+# key1 Athena
+# key1 Apollo
+# key1 Gemini
+#
+# Things get combinatoric when multiple reference list fields are involved. Our
+# strategy here is to keep gathering all fields that change into arrays assuming
+# they are reference fields as long as the dbid field has not changed.
+my %record;
+
+while () {
+ unless ($result->{lastDBID}) {
+ # Move to the first record
+ last unless $result->{result}->MoveNext == $CQPerlExt::CQ_SUCCESS;
+ } elsif ($result->{lastDBID} == $result->{thisDBID}) {
+ # If the dbid is the same then we have at least one reference list field
+ # in the request so we need to move to the next record
+ last unless $result->{result}->MoveNext == $CQPerlExt::CQ_SUCCESS;
+ } else {
+ # If lastDBID != thisDBID then set lastDBID to thisDBID so we can process
+ # this group
+ $result->{lastDBID} = $result->{thisDBID};
+
+ delete $result->{lastRecord};
+ } # unless
+
+ my $nbrColumns = $result->{result}->GetNumberOfColumns;
+
+ my $column = 1;
+
+ # Format %record
+ while ($column <= $nbrColumns) {
+ my $value = $result->{result}->GetColumnValue ($column);
+
+ $value ||= '' if $self->{emptyStringForUndef};
+
+ # Fix any UTC dates - _UTC2Localtime will only modify data if the data
+ # matches a UTC datetime.
+ $value = _UTC2Localtime ($value);
+
+ $record{$result->{result}->GetColumnLabel ($column++)} = $value;
+ } # while
+
+ %{$result->{lastRecord}} = %record unless $result->{lastRecord};
+
+ # Store this record's DBID
+ $result->{thisDBID} = $record{dbid};
+
+ if ($result->{lastDBID}) {
+ if ($result->{thisDBID} == $result->{lastDBID}) {
+ # Since the dbid's are the same, we have at least one reference list field
+ # and we need to compare all fields
+ foreach my $field (keys %record) {
+ # If the field is blank then skip it
+ next if $record{$field} eq '';
+
+ # Here we check the field in %lastRecord to see if it was a reference
+ # list with more than one entry.
+ if (ref \$result->{lastRecord}{$field} eq 'ARRAY') {
+ # Check to see if this entry is already in the list of current entries
+ next if grep {/^$record{$field}$/} @{$result->{lastRecord}{$field}};
+ } # if
+
+ # This checks to see if the current field is a scalar and we have a new
+ # value, then the scalar needs to be changed to an array
+ if (ref \$result->{lastRecord}{$field} eq 'SCALAR') {
+ # If the field is the same value then no change, no array. We do next
+ # to start processing the next field
+ next if $result->{lastRecord}{$field} eq $record{$field};
+
+ # Changed $lastRecord{$_} to a reference to an ARRAY
+ $result->{lastRecord}{$field} = [$result->{lastRecord}{$field}, $record{$field}];
+ } else {
+ # Push the value only if it does not already exists in the array
+ push @{$result->{lastRecord}{$field}}, $record{$field}
+ unless grep {/^$record{$field}$/} @{$result->{lastRecord}{$field}};
+ } # if
+ } # foreach
+
+ # Transfer %lastRecord -> %record
+ %record = %{$result->{lastRecord}};
+ } else {
+ %record = %{$result->{lastRecord}};
+
+ last;
+ } # if
+ } # if
+
+ # The $lastDBID is now $thisDBID
+ $result->{lastDBID} = $result->{thisDBID};
+
+ # Update %lastRecord
+ %{$result->{lastRecord}} = %record;
+} # while
+
+ $self->_setError;
+
+ return %record;
+} # getNext
+
+sub id2db ($) {
+ my ($ID) = @_;
+
+=pod
+
+=head2 id2db ($)
+
+This function returns the database name given an ID.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $ID
+
+The ID to extract the database name from
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $database
+
+Returns the name of the database the ID is part of or undef if not found.
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ if ($ID =~ /([A-Za-z]\w{1,4})\d{8}/) {
+ return $1;
+ } else {
+ return;
+ } # if
+} # id2db
+
+sub key ($$) {
+ my ($self, $table, $dbid) = @_;
+
+=pod
+
+=head2 key ($$)
+
+Return the key of the record given a $dbid
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $table
+
+Name of the table to lookup
+
+=item $dbid
+
+Database ID of the record to retrieve
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item key
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ unless ($self->connected) {
+ $self->_setError ('You must connect to Clearquest before you can call key', '-1');
+
+ return;
+ } # unless
+
+ my $entity;
+
+ eval {$entity = $self->{session}->GetEntityByDbId ($table, $dbid)};
+
+ return $entity->GetDisplayName;
+} # key
+
+sub modify ($$$$;@) {
+ my ($self, $table, $key, $action, $values, @ordering) = @_;
+
+=pod
+
+=head2 modify ($$$$;@)
+
+Update record(s)
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $table
+
+The $table to get the record from
+
+=item $key
+
+The $key identifying the record to modify
+
+=item $action
+
+Action to perform the modification under. Default is 'Modify'.
+
+=item $values
+
+Hash reference containing name/value that have the new values for the fields
+
+=item @ordering
+
+Array containing field names that need to be processed in order. Not all fields
+mentioned in the $values hash need be mentioned here. If you have fields that
+must be set in a particular order you can mention them here. So, if you're
+modifying the Defect record, but you need Project set before Platform, you need
+only pass in an @ordering of qw(Project Platform). They will be done first, then
+all of the rest of the fields in the $values hash. If you have no ordering
+dependencies then you can simply omit @ordering.
+
+Note that the best way to determine if you have an ordering dependency try using
+a Clearquest client and note the order that you set fields in. If at anytime
+setting one field negates another field via action hook code then you have just
+figured out that this field needs to be set before the file that just got
+negated.
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $errmsg
+
+The $errmsg, if any, when performing the update (empty string for success)
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ unless ($self->connected) {
+ $self->_setError ('You must connect to Clearquest before you can call modify', '-1');
+
+ return $self->{errmsg};
+ } # unless
+
+ my %record = $self->get ($table, $key, qw(dbid));
+
+ return $self->modifyDBID ($table, $record{dbid}, $action, $values, @ordering);
+} # modify
+
+sub modifyDBID ($$$$;@) {
+ my ($self, $table, $dbid, $action, $values, @ordering) = @_;
+
+=pod
+
+=head2 modifyDBID ($$$%)
+
+Update a unique record (by DBID)
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $table
+
+The $table to get the record from
+
+=item $dbid
+
+The $dbid of the record to update. Note that the find method always includes the
+dbid of a record in the hash that it returns.
+
+=item $action
+
+Action to perform the modification under. Default is 'Modify'.
+
+=item %update
+
+Hash containing name/value that have the new values for the fields
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $errmsg
+
+The $errmsg, if any, when performing the update (empty string for success)
+
+=back
+
+=for html </blockquote>
+
+=cut
+ $action ||= 'Modify';
+
+ my %values = %$values;
+
+ my $entity;
+
+ eval {$entity = $self->{session}->GetEntityByDbId ($table, $dbid)};
+
+ if ($@) {
+ $self->_setError ($@);
+
+ return;
+ } # if
+
+ eval {$entity->EditEntity ($action)};
+
+ if ($@) {
+ $self->_setError ($@);
+
+ return $@;
+ } # if
+
+ # First process all fields in @ordering, if specified
+ foreach (@ordering) {
+ if ($values{$_}) {
+ $self->{errmsg} = $self->_setFieldValue ($table, $_, $values{$_});
+ } else {
+ $self->_setError ("$_ from the ordering array is not present in the value hash", -1);
+ } # if
+
+ last unless $self->{errmsg} eq '';
+ } # foreach
+
+ return $self->{errmsg} unless $self->{errmsg} eq '';
+
+ # Now process the rest of the values
+ foreach my $fieldName (keys %values) {
+ next if grep {$fieldName eq $_} @ordering;
+
+ $self->{errmsg} = $self->_setFieldValue ($entity, $table, $fieldName, $values{$fieldName});
+
+ last unless $self->{errmsg} eq '';
+ } # foreach
+
+ $self->_setError ($self->{errmsg});
+
+ return $self->{errmsg} unless $self->{errmsg} eq '';
+
+ $self->{errmsg} = $self->_commitRecord ($entity);
+ $self->{error} = $self->{errmsg} eq '' ? 0 : 1;
+
+ return $self->{errmsg};
+} # modifyDBID
+
+sub module () {
+ my ($self) = @_;
+
+=pod
+
+=head2 module
+
+Returns the current back end module we are using
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item module
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{module};
+} # module
+
+sub new (;%) {
+ my ($class, %parms) = @_;
+
+=pod
+
+=head2 new ()
+
+Construct a new Clearquest object.
+
+Parameters:
+
+Below are the key values for the %parms hash.
+
+=for html <blockquote>
+
+=over
+
+=item CQ_SERVER
+
+Webhost for REST module
+
+=item CQ_USERNAME
+
+Username to use to connect to the database
+
+=item CQ_PASSWORD
+
+Password to use to connect to the database
+
+=item CQ_DATABASE
+
+Clearquest database to connect to
+
+=item CQ_DBSET
+
+Database set to connect to
+
+=item CQ_MODULE
+
+One of 'rest', 'api' or 'client' (Default: From cq.conf). This determines which
+backend module will be used.
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Clearquest object
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $parms{CQ_DATABASE} ||= $OPTS{CQ_DATABASE};
+ $parms{CQ_USERNAME} ||= $OPTS{CQ_USERNAME};
+ $parms{CQ_PASSWORD} ||= $OPTS{CQ_PASSWORD};
+ $parms{CQ_DBSET} ||= $OPTS{CQ_DBSET};
+
+ my $self = bless {
+ server => $parms{CQ_SERVER},
+ port => $parms{CQ_PORT},
+ database => $parms{CQ_DATABASE},
+ dbset => $parms{CQ_DBSET},
+ username => $parms{CQ_USERNAME},
+ password => $parms{CQ_PASSWORD},
+ emptyStringForUndef => 0,
+ returnSystemFields => 0,
+ }, $class;
+
+ my $module = delete $parms{CQ_MODULE};
+
+ $module ||= $OPTS{CQ_MODULE};
+
+ $module = lc $module;
+
+ if ($module eq 'rest') {
+ require Clearquest::REST;
+
+ $self->{webhost} = $parms{CQ_WEBHOST} || $OPTS{CQ_WEBHOST};
+
+ $self = Clearquest::REST->new ($self);
+ } elsif ($module eq 'client') {
+ require Clearquest::Client;
+
+ $self->{server} = $parms{CQ_SERVER} || $OPTS{CQ_SERVER};
+ $self->{port} = $parms{CQ_PORT} || $OPTS{CQ_PORT};
+
+ $self = Clearquest::Client->new ($self);
+ } elsif ($module ne 'api') {
+ croak "Unknown interface requested - $module";
+ } # if
+
+ $self->{module} = $module;
+
+ # Save reference to instaniated instance of this object to insure that global
+ # variables are properly disposed of
+ push @objects, $self;
+
+ return $self;
+} # new
+
+sub server () {
+ my ($self) = @_;
+
+=pod
+
+=head2 server
+
+Returns the current server if applicable
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $server
+
+For api this will return ''. For REST and client/server this will return the
+server name that we are talking to.
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{server};
+} # server
+
+sub setOpts (%) {
+ my ($self, %opts) = @_;
+
+=pod
+
+=head2 setOpts
+
+Set options for operating
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item %opts
+
+=back
+
+Options to set. The only options currently supported are emptyStringForUndef
+and returnSystemFields. If set emptyStringForUndef will return empty strings for
+empty fields instead of undef. Default: Empty fields are represented with undef.
+
+System-owned fields are used internally by IBM Rational ClearQuest to maintain
+information about the database. You should never modify system fields directly
+as it could corrupt the database. If returnSystemFields is set then system
+fields will be returned. Default: System fields will not be returned unless
+explicitly stated in the @fields parameter. This means that if you do not
+specify any fields in @fields, all fields will be returned except system fields,
+unless you set returnSystemFields via this method or you explicitly mention the
+system field in your @fields parameter.
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Nothing
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $self->{emptyStringForUndef} = $opts{emptyStringForUndef}
+ if $opts{emptyStringForUndef};
+ $self->{returnSystemFields} = $opts{returnSystemFields}
+ if $opts{returnSystemFields};
+} # setOpts
+
+sub getOpt ($) {
+ my ($self, $option) = @_;
+
+=pod
+
+=head2 getOpt
+
+Get option
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $option
+
+=back
+
+Option to retrieve. If non-existant then undef is returned.
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $option or undef if option doesn't exist
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my @validOpts = qw (emptyStringForUndef returnSystemFields);
+
+ if (grep {$option eq $_} @validOpts) {
+ return $self->{$option};
+ } else {
+ return;
+ } # if
+} # getOpt
+
+sub username () {
+ my ($self) = @_;
+
+=pod
+
+=head2 username
+
+Returns the current username (or the username that would be used)
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item username
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{username};
+} # username
+
+sub webhost () {
+ my ($self) = @_;
+
+ return $self->{webhost};
+} # webhost
+
+1;
+
+=pod
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<File::Basename|File::Basename>
+
+=head2 ClearSCM Perl Modules
+
+=for html <p><a href="/php/cvs_man.php?file=lib/GetConfig.pm">GetConfig</a></p>
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this module
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2007, ClearSCM, Inc. All rights reserved.
+
+=cut
--- /dev/null
+=pod
+
+=head1 NAME $RCSfile: Admin.pm,v $
+
+Clearquest Admin - Provide access Clearquest AdminSession objects
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.3 $
+
+=item Created
+
+Wed Apr 18 09:59:47 PDT 2012
+
+=item Modified
+
+$Date: 2012/11/09 06:53:11 $
+
+=back
+
+=head1 SYNOPSIS
+
+Provides an interface to the Clearquest AdminSession objects. These are for
+dealing with objects in the schema, not the user database.
+
+=head1 DESCRIPTION
+
+The Admin object allows you to create a session object associated with a schema
+repository. This allows you to retrieve and modify information in a schema
+repository. You must log into the Admin object as an admin user.
+
+Functions are available to deal with users, groups, databases and schemas.
+
+Note: Admin object needs to be filled out with more functions over time...
+
+=head1 ROUTINES
+
+The following methods are available:
+
+=cut
+
+package Clearquest::Admin;
+
+use strict;
+use warnings;
+
+use Carp;
+use File::Basename;
+use FindBin;
+
+use DateUtils;
+use Display;
+use GetConfig;
+
+use Clearquest;
+
+# Seed options from config file
+my $config = $ENV{CQD_CONF} || dirname (__FILE__) . '/../../etc/cqdservice.conf';
+
+croak "Unable to find config file $config" unless -r $config;
+
+our %OPTS = GetConfig $config;
+
+our $VERSION = '$Revision: 1.3 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+# Override options if in the environment
+$OPTS{CQD_HOST} = $ENV{CQD_HOST}
+ if $ENV{CQD_HOST};
+$OPTS{CQD_PORT} = $ENV{CQD_PORT}
+ if $ENV{CQD_PORT};
+$OPTS{CQD_MULTITHREADED} = $ENV{CQD_MULTITHREADED}
+ if defined $ENV{CQD_MULTITHREADED};
+$OPTS{CQD_DATABASE} = $ENV{CQD_DATABASE}
+ if $ENV{CQD_DATABASE};
+$OPTS{CQD_USERNAME} = $ENV{CQD_USERNAME}
+ if $ENV{CQD_USERNAME};
+$OPTS{CQD_PASSWORD} = $ENV{CQD_PASSWORD}
+ if $ENV{CQD_PASSWORD};
+$OPTS{CQD_DBSET} = $ENV{CQD_DBSET}
+ if $ENV{CQD_DBSET};
+
+sub getUser ($) {
+ my ($self, $loginname) = @_;
+
+=pod
+
+=head2 getUser ($)
+
+Returns a user object for the specified user or undef.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $username
+
+The $loginname to retrieve the user object for
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item User object
+
+A user object
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{session}->GetUser ($loginname);
+} # getNext
+
+sub userActive ($) {
+ my ($self, $loginname) = @_;
+
+=pod
+
+=head2 userActive ($)
+
+Returns a true if user is active
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $username
+
+The $loginname to see if active
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item 1 if true, 0 if false
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my $user = $self->getUser ($loginname);
+
+ if ($user) {
+ return $user->GetActive;
+ } else {
+ return 0;
+ } # if
+} # userActive
+
+sub userActivate ($) {
+ my ($self, $loginname) = @_;
+
+=pod
+
+=head2 userActivate ($)
+
+Activates a user if they were inactive
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $username
+
+The $loginname to activate
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item nothing
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ unless ($self->activeUser ($logname)) {
+ my $user = $self->getUser ($loginname);
+
+ if ($user) {
+ $user->SetUser (1);
+ } # if
+ } # unless
+} # userActive
+
+sub userActivate ($) {
+ my ($self, $loginname) = @_;
+
+=pod
+
+=head2 userInactivate ($)
+
+Inactivates a user if they were active
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $username
+
+The $loginname to inactivate
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item nothing
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ if ($self->activeUser ($logname)) {
+ my $user = $self->getUser ($loginname);
+
+ if ($user) {
+ $user->SetUser (0);
+ } # if
+ } # unless
+} # userInactive
+
+sub new () {
+ my ($class, $username, $password, $dbset) = @_;
+
+ my $self = bless {}, $class;
+
+ if (ref $username eq 'HASH') {
+ my %parms = %$username;
+
+ $self->{username} = $parms{username};
+ $self->{password} = $parms{password};
+ $self->{dbset} = $parms{dbset};
+ } else {
+ $self->{username} = $username;
+ $self->{password} = $password;
+ $self->{dbset} = $dbset;
+ } # if
+
+ return $self;
+} # new
+
+sub connect (;$$$) {
+
+=pod
+
+=head2 connect (;$$$)
+
+Connect to the Clearquest schema database. You can supply parameters such as
+username, password, etc and they will override any passed to
+Clearquest::Admin::new (or those coming from ../etc/cq.conf)
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $username
+
+Username to use to connect to the schema database
+
+=item $password
+
+Password to use to connect to the schema database
+
+=item $dbset
+
+Database set to connect to (Default: Connect to the default dbset)
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item 1
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my ($self, $username, $password, $dbset) = @_;
+
+ $self->{username} = $username if $username;
+ $self->{password} = $password if $password;
+ $self->{database} = $database if $database;
+ $self->{dbset} = $dbset if $dbset;
+
+ $self->{session} = CQAdminSession::Build;
+
+ # TODO: Should handle failures better
+ $self->{session}->($self->{username},
+ $self->{password},
+ $self->{dbset});
+ $self->{loggedin} = 1;
+
+ return $self->{loggedin};
+} # connect
+
+sub connected () {
+ my ($self) = @_;
+
+=pod
+
+=head2 connected ()
+
+Returns 1 if we are currently connected to a Clearquest Admin Schema Database
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item 1 if logged in - 0 if not
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{loggedin};
+} # connected
+
+sub disconnect () {
+ my ($self) = @_;
+
+=pod
+
+=head2 disconnect ()
+
+Disconnect from Clearquest Admin Schema Database
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item nothing
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ CQAdminSession::Unbuild ($self->{session});
+
+ undef $self->{session};
+
+ $self->{loggedin} = 0;
+
+ return;
+} # disconnect
+
+
+
+1;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<Carp>
+
+L<File::Basename|File::Basename>
+
+L<FindBin>
+
+L<IO::Socket|IO::Socket>
+
+L<Net::hostent|Net::hostent>
+
+L<POSIX>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ DateUtils
+ Display
+ GetConfig
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/DateUtils.pm">DateUtils</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/GetConfig.pm">GetConf</a><br>
+</blockquote>
+
+=end html
+
+=head1 SEE ALSO
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this module.
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2011, ClearSCM, Inc. All rights reserved.
+
+=cut
--- /dev/null
+=pod
+
+=head1 NAME $RCSfile: Client.pm,v $
+
+Clearquest client - Provide access to a running Clearquest server
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 2.8 $
+
+=item Created
+
+Monday, October 10, 2011 5:02:07 PM PDT
+
+=item Modified
+
+$Date: 2013/05/30 15:43:28 $
+
+=back
+
+=head1 SYNOPSIS
+
+Provides an interface to a running Clearquest Server over the network. This
+means that you can use any Perl you like, not just cqperl, and you don't need
+to have Clearquest installed locally. In fact you can run from say Linux and
+talk to the Clearquest Server running on Windows.
+
+=head1 DESCRIPTION
+
+The server allows both read and write access to a Clearquest database as defined
+in cqdservice.conf file. Note the username/password must be of a user who can
+write to the Clearquest database for write access to succeed.
+
+A hash is passed into to the execute method, which the client should use to talk
+to the server, that describes relatively simple protocol to tell the server what
+action to perform. In both the read case and the read/write case a field named
+id should be defined that has a value of "<record>=<id>" (e.g.
+"defect=BUGDB00034429").
+
+For the read case the rest of the keys are the names of the fields to retrieve
+with values that are undef'ed. For read/write, the rest of hash contains name
+value pairs of fields to set and their values.
+
+Execute returns a status and a hash of name value pairs for the read case and an
+array of lines for any error messages for the read/write case.
+
+=head1 ROUTINES
+
+The following methods are available:
+
+=cut
+
+package Clearquest::Client;
+
+use strict;
+use warnings;
+
+use Carp;
+use File::Basename;
+use FindBin;
+use IO::Socket;
+use Net::hostent;
+use POSIX ":sys_wait_h";
+use Data::Dumper;
+
+use Clearquest;
+
+use parent 'Clearquest';
+
+$Data::Dumper::Indent = 0;
+
+our $VERSION = '$Revision: 2.8 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+=pod
+
+=head1 Options
+
+Options are keep in the cq.conf file in the etc directory. They specify the
+default options listed below. Or you can export the option name to the env(1) to
+override the defaults in cq.conf. Finally you can programmatically set the
+options when you call new by passing in a %parms hash. The items below are the
+key values for the hash.
+
+=for html <blockquote>
+
+=over
+
+=item CQ_SERVER
+
+The CQ Server host to connect to
+
+=item CQ_PORT
+
+Port number to contact the server at (Default: From cq.conf)
+
+=item CQ_USERNAME
+
+User name to connect as (Default: From cq.conf)
+
+=item CQ_PASSWORD
+
+Password for CQ_USERNAME
+
+=item CQ_DATABASE
+
+Name of database to connect to (Default: From cq.conf)
+
+=item CQ_DBSET
+
+Database Set name (Default: From cq.conf)
+
+=back
+
+=cut
+
+sub _parseCmd ($) {
+ my ($self, $cmd) = @_;
+} # _parseCmd
+
+sub _request ($;@) {
+ my ($self, $call, @parms) = @_;
+
+ my $server = $self->{socket};
+
+ my $request = $call;
+
+ $request .= ' ';
+ $request .= Dumper \@parms;
+ $request .= "\n";
+
+ # Send request
+ print $server $request;
+
+ # Get response
+ my ($response, $status, @output);
+
+ while (defined ($response = <$server>)) {
+ if ($response =~ /Clearquest::Server Status: (-*\d+)/) {
+ $status = $1;
+ last;
+ } # if
+
+ chomp $response; chop $response if $response =~ /\r$/;
+
+ push @output, $response;
+ } # while
+
+ unless (@output) {
+ push @output, 'Unknown or unhandled error';
+
+ $status = -1;
+ } # unless
+
+ $self->_setError (join ("\n", @output), $status) if $status;
+
+ return ($status, @output);
+} # _request
+
+sub add ($$;@) {
+ my ($self, $table, $values, @ordering) = @_;
+
+ my @parms;
+
+ push @parms, $table, Dumper ($values), @ordering;
+
+ $self->_request ('add', @parms);
+
+ return $self->errmsg;
+} # add
+
+sub connect (;$$$$) {
+ my ($self, $username, $password, $database, $dbset) = @_;
+
+ return $self->connectToServer;
+} # connect
+
+sub connectToServer (;$$) {
+ my ($self, $server, $port) = @_;
+
+ $self->{socket} = IO::Socket::INET->new (
+ Proto => 'tcp',
+ PeerAddr => $self->{server},
+ PeerPort => $self->{port},
+ );
+
+ unless ($self->{socket}) {
+ $self->_setError ($!, 1);
+
+ return;
+ } # unless
+
+ $self->{socket}->autoflush;
+
+ # Now tell the server what database we wish to use
+ my ($status, @output) = $self->_request (
+ 'open',
+ $self->{database},
+ $self->{username},
+ $self->{password},
+ $self->{dbset},
+ );
+
+ $self->{loggedin} = $status == 0;
+
+ $self->_setError (@output, $status);
+
+ return $self->connected;
+} # connectToServer
+
+sub dbsets () {
+ my ($self) = @_;
+
+ my ($status, @output) = $self->_request ('dbsets');
+
+ return @output;
+} # dbsets
+
+sub delete ($$) {
+ my ($self, $table, $key) = @_;
+
+ my @parms;
+
+ push @parms, $table;
+ push @parms, $key;
+
+ my ($status, @output) = $self->_request ('delete', @parms);
+
+ return $self->errmsg;
+} # delete
+
+sub DESTROY () {
+ my ($self) = @_;
+
+ $self->disconnectFromServer;
+} # DESTROY
+
+sub disconnect () {
+ my ($self) = @_;
+
+ $self->disconnectFromServer;
+
+ $self->{loggedin} = 0;
+
+ return;
+} # disconnect
+
+sub disconnectFromServer () {
+ my ($self) = @_;
+
+ if ($self->{socket}) {
+ $self->_request ('end');
+
+ close $self->{socket};
+
+ undef $self->{socket};
+ } # if
+
+ return;
+} # disconnectFromServer
+
+sub find ($;$@) {
+ my ($self, $table, $condition, @fields) = @_;
+
+ $condition ||= '';
+
+ # TODO: Need to return nbrrecs
+ my ($status, @output) = $self->_request ('find', $table, $condition, @fields);
+
+ if ($self->error) {
+ return (undef, $self->errmsg);
+ } else {
+ return ($status, $output[1]);
+ } # if
+} # find
+
+sub get ($$@) {
+ my ($self, $table, $key, @fields) = @_;
+
+ my %record;
+
+ $self->_setError ('', 0);
+
+ my ($status, @output) = $self->_request ('get', $table, $key, @fields);
+
+ return if $status;
+
+ foreach (@output) {
+ my ($field, $value) = split /\@\@/;
+
+ $value =~ s/ /\n/g;
+
+ if ($record{$field}) {
+ if (ref $record{$field} ne 'ARRAY') {
+ my $valueOne = $record{$field};
+
+ $record{$field} = ();
+
+ push @{$record{$field}}, $valueOne, $value;
+ } else {
+ push @{$record{$field}}, $value;
+ } # if
+ } else {
+ $record{$field} = $value;
+ } # if
+ } # foreach
+
+ return %record;
+} # get
+
+sub getDBID ($$@) {
+ my ($self, $table, $dbid, @fields) = @_;
+
+ my %record = ();
+
+ my ($status, @output) = $self->_request ('getDBID', $table, $dbid, @fields);
+
+ return ($status, %record) if $status;
+
+ foreach (@output) {
+ my ($field, $value) = split /\@\@/;
+
+ $value =~ s/ /\n/g;
+
+ if ($record{$field}) {
+ if (ref $record{$field} ne 'ARRAY') {
+ my $valueOne = $record{$field};
+
+ $record{$field} = ();
+
+ push @{$record{$field}}, $valueOne, $value;
+ } else {
+ push @{$record{$field}}, $value;
+ } # if
+ } else {
+ $record{$field} = $value;
+ } # if
+ } # foreach
+
+ return %record;
+} # getDBID
+
+sub getDynamicList ($) {
+ my ($self, $list) = @_;
+
+ my ($status, @output) = $self->_request ('getDynamicList', $list);
+
+ return @output;
+} # getDynamicList
+
+sub getNext ($) {
+ my ($self, $result) = @_;
+
+ my ($status, @output) = $self->_request ('getNext', ());
+
+ return if $status;
+
+ my %record;
+
+ foreach (@output) {
+ my ($field, $value) = split /\@\@/;
+
+ $value =~ s/ /\n/g;
+
+ if ($record{$field}) {
+ if (ref $record{$field} ne 'ARRAY') {
+ push @{$record{$field}}, $record{$field}, $value;
+ } else {
+ push @{$record{$field}}, $value;
+ } # if
+ } else {
+ $record{$field} = $value;
+ } # if
+ } # foreach
+
+ return %record;
+} # getNext
+
+sub key ($$) {
+ my $self = shift;
+
+ my ($status, @output) = $self->_request ('key', @_);
+
+ return $output[0];
+} # key
+
+sub modify ($$$$;@) {
+ my ($self, $table, $key, $action, $values, @ordering) = @_;
+
+ $action ||= 'Modify';
+
+ my @parms;
+
+ push @parms, $table, $key, $action, Dumper ($values), @ordering;
+
+ $self->_request ('modify', @parms);
+
+ return $self->errmsg;
+} # modify
+
+sub modifyDBID ($$$$;@) {
+ my ($self, $table, $dbid, $action, $values, @ordering) = @_;
+
+ my @parms;
+
+ push @parms, $table, $dbid, $action, Dumper ($values), @ordering;
+
+ $self->_request ('modifyDBID', @parms);
+
+ return $self->errmsg;
+} # modifyDBID
+
+sub port () {
+ my ($self) = @_;
+
+ return $self->{port};
+} # port
+
+sub new () {
+ my ($class, $self) = @_;
+
+ $$self{server} ||= $Clearquest::OPTS{CQ_SERVER};
+ $$self{port} ||= $Clearquest::OPTS{CQ_PORT};
+
+ bless $self, $class;
+} # new
+
+sub shutdown () {
+ my ($self) = @_;
+
+ if ($self->{socket}) {
+ $self->_request ('shutdown');
+ } # if
+} # shutdown
+
+1;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<Carp>
+
+L<File::Basename|File::Basename>
+
+L<FindBin>
+
+L<IO::Socket|IO::Socket>
+
+L<Net::hostent|Net::hostent>
+
+L<POSIX>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ DateUtils
+ Display
+ GetConfig
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/DateUtils.pm">DateUtils</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/GetConfig.pm">GetConf</a><br>
+</blockquote>
+
+=end html
+
+=head1 SEE ALSO
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this module.
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2011, ClearSCM, Inc. All rights reserved.
+
+=cut
--- /dev/null
+=pod
+
+=head1 NAME $RCSfile: DBService.pm,v $
+
+DB Service - Provide access to Clearquest database
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.2 $
+
+=item Created
+
+Monday, October 10, 2011 5:02:07 PM PDT
+
+=item Modified
+
+$Date: 2011/12/31 02:13:37 $
+
+=back
+
+=head1 SYNOPSIS
+
+Provides an interface to the Clearquest database over the network.
+
+This library implements both the daemon portion of the server and the client
+API.
+
+=head1 DESCRIPTION
+
+The server allows both read and write access to a Clearquest database as defined
+in cqdservice.conf file. Note the username/password must be of a user who can
+write to the Clearquest database for write access to succeed.
+
+A hash is passed into to the execute method, which the client should use to talk
+to the server, that describes relatively simple protocol to tell the server what
+action to perform. In both the read case and the read/write case a field named
+id should be defined that has a value of "<record>=<id>" (e.g.
+"defect=BUGDB00034429").
+
+For the read case the rest of the keys are the names of the fields to retrieve
+with values that are undef'ed. For read/write, the rest of hash contains name
+value pairs of fields to set and their values.
+
+Execute returns a status and a hash of name value pairs for the read case and an
+array of lines for any error messages for the read/write case.
+
+=head1 ROUTINES
+
+The following methods are available:
+
+=cut
+
+package Clearquest::DBService;
+
+use strict;
+use warnings;
+
+use Carp;
+use File::Basename;
+use FindBin;
+use IO::Socket;
+use Net::hostent;
+use POSIX ":sys_wait_h";
+
+use DateUtils;
+use Display;
+use GetConfig;
+
+# Seed options from config file
+my $config = $ENV{CQD_CONF} || dirname (__FILE__) . '/../../etc/cqdservice.conf';
+
+croak "Unable to find config file $config" unless -r $config;
+
+our %OPTS = GetConfig $config;
+
+our $VERSION = '$Revision: 1.2 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+# Override options if in the environment
+$OPTS{CQD_HOST} = $ENV{CQD_HOST}
+ if $ENV{CQD_HOST};
+$OPTS{CQD_PORT} = $ENV{CQD_PORT}
+ if $ENV{CQD_PORT};
+$OPTS{CQD_MULTITHREADED} = $ENV{CQD_MULTITHREADED}
+ if defined $ENV{CQD_MULTITHREADED};
+$OPTS{CQD_DATABASE} = $ENV{CQD_DATABASE}
+ if $ENV{CQD_DATABASE};
+$OPTS{CQD_USERNAME} = $ENV{CQD_USERNAME}
+ if $ENV{CQD_USERNAME};
+$OPTS{CQD_PASSWORD} = $ENV{CQD_PASSWORD}
+ if $ENV{CQD_PASSWORD};
+$OPTS{CQD_DBSET} = $ENV{CQD_DBSET}
+ if $ENV{CQD_DBSET};
+
+sub new () {
+ my ($class) = @_;
+
+ my $cqdservice = bless {}, $class;
+
+ $cqdservice->{multithreaded} = $OPTS{CQD_MULTITHREADED};
+
+ return $cqdservice;
+} # new
+
+sub _tag ($) {
+ my ($self, $msg) = @_;
+
+ my $tag = YMDHMS;
+ $tag .= ' ';
+ $tag .= $self->{pid} ? "[$self->{pid}] " : '';
+
+ return "$tag$msg";
+} # _tag
+
+sub _verbose ($) {
+ my ($self, $msg) = @_;
+
+ verbose $self->_tag ($msg);
+
+ return;
+} # _verbose
+
+sub _debug ($) {
+ my ($self, $msg) = @_;
+
+ debug $self->_tag ($msg);
+
+ return;
+} # _debug
+
+sub _log ($) {
+ my ($self, $msg) = @_;
+
+ display $self->_tag ($msg);
+
+ return;
+} # log
+
+sub _funeral () {
+ debug 'Entered _funeral';
+
+ while (my $childpid = waitpid (-1, WNOHANG) > 0) {
+ my $status = $?;
+
+ debug "childpid: $childpid - status: $status";
+
+ if ($childpid != -1) {
+ local $SIG{CHLD} = \&_funeral;
+
+ my $msg = 'Child has died';
+ $msg .= $status ? " with status $status" : '';
+
+ verbose "[$childpid] $msg"
+ if $status;
+ } else {
+ debug "All children reaped";
+ } # if
+ } # while
+
+ return;
+} # _funeral
+
+sub _endServer () {
+ display "CQDService V$VERSION shutdown at " . localtime;
+
+ # Kill process group
+ kill 'TERM', -$$;
+
+ # Wait for all children to die
+ while (wait != -1) {
+ # do nothing
+ } # while
+
+ # Now that we are alone, we can simply exit
+ exit;
+} # _endServer
+
+sub _restartServer () {
+ # Not sure what to do on a restart server
+ display 'Entered _restartServer';
+
+ return;
+} # _restartServer
+
+sub setMultithreaded ($) {
+ my ($self, $value) = @_;
+
+ my $oldValue = $self->{multithreaded};
+
+ $self->{multithreaded} = $value;
+
+ return $oldValue;
+} # setMultithreaded
+
+sub getMultithreaded () {
+ my ($self) = @_;
+
+ return $self->{multithreaded};
+} # getMultithreaded
+
+sub connectToServer (;$$) {
+ my ($self, $host, $port) = @_;
+
+ $host ||= $OPTS{CQD_HOST};
+ $port ||= $OPTS{CQD_PORT};
+
+ $self->{socket} = IO::Socket::INET->new (
+ Proto => 'tcp',
+ PeerAddr => $host,
+ PeerPort => $port,
+ );
+
+ return unless $self->{socket};
+
+ $self->{socket}->autoflush;
+
+ $self->{host} = $host;
+ $self->{port} = $port;
+
+ return $self->{socket} ? 1 : 0;
+} # connectToServer
+
+sub disconnectFromServer () {
+ my ($self) = @_;
+
+ if ($self->{socket}) {
+ close $self->{socket};
+
+ undef $self->{socket};
+ } # if
+
+ return;
+} # disconnectFromServer
+
+# TODO: This function should not be internal and it should be overridable
+sub _serviceClient ($$) {
+ my ($self, $host, $client) = @_;
+
+ $self->_verbose ("Serving requests from $host");
+
+ # Set autoflush for client
+ $client->autoflush
+ if $client;
+
+ # Input is simple and consists of the following:
+ #
+ # <recordType>=<ID>
+ # <fieldname>=<fieldvalue>
+ # <fieldname>+=<fieldvalue>
+ # ...
+ # end
+ #
+ # Notes: <ID> can be <ID_scope>. Also a += means append this fieldvalue to
+ # the existing value for the field.
+
+ # First get record line
+ my $line = <$client>;
+
+ if ($line) {
+ chomp $line; chop $line if $line =~ /\r$/;
+ } else {
+ $self->_verbose ("Host $host went away!");
+
+ close $client;
+
+ return;
+ } # if
+
+ if ($line =~ /stopserver/i) {
+ if ($self->{server}) {
+ $self->_verbose ("$host requested to stop server [$self->{server}]");
+
+ # Send server hangup signal
+ kill 'HUP', $self->{server};
+ } else {
+ $self->_verbose ('Shutting down server');
+
+ print $client "CQDService Status: 0\n";
+
+ exit;
+ } # if
+ } # if
+
+ my ($record, $id) = split /=/, $line;
+
+ unless ($id) {
+ $self->_verbose ('Garbled record line - rejected request');
+
+ close $client;
+
+ return;
+ } # unless
+
+ $self->_verbose ("Client wishes to deal with $id");
+
+ my $scope;
+
+ if ($id =~ /_(\S+)/) {
+ $scope = $1;
+ } # if
+
+ $self->_debug ("$host wants $record:$id");
+
+ my ($read, %fields);
+
+ # Now read name/value pairs
+ while () {
+ # Read command from client
+ $line = <$client>;
+
+ if ($line) {
+ chomp $line; chop $line if $line =~ /\r$/;
+ } else {
+ $self->_verbose ("Host $host went away!");
+
+ close $client;
+
+ return;
+ } # if
+
+ last if $line =~ /^end$/i;
+
+ # Collect name/values. Note if only names are requested then we will instead
+ # return data.
+ my ($name, $value) = split /=/, $line;
+
+ if ($value) {
+ # Transform %0A's back to \n
+ $value =~ s/\%0A/\n/g;
+
+ $self->_verbose ("Will set $name to $value");
+ } else {
+ $read = 1;
+ $self->_verbose ("Will retrieve $name");
+ } # if
+
+ $fields{$name} = $value;
+ } # while
+
+ # Get record
+ my $entity;
+
+ $self->_verbose ("Getting $record:$id");
+
+ eval { $entity = $self->{session}->GetEntity ($record, $id) };
+
+ unless ($entity) {
+ print $client "Unable to GetEntity $record:$id\n";
+
+ close $client;
+
+ return;
+ } # unless
+
+ if ($read) {
+ print $client "$_@@" . $entity->GetFieldValue ($_)->GetValue . "\n"
+ foreach (keys %fields);
+ print $client "CQD Status: 0\n";
+
+ close $client;
+
+ return;
+ } # if
+
+ # Edit record
+ $self->_verbose ("Editing $id");
+
+ $entity->EditEntity ('Backend');
+
+ my $status;
+
+ foreach my $fieldName (keys %fields) {
+ if ($fieldName =~ /(.+)\*$/) {
+ my $newValue = delete $fields{$fieldName};
+
+ $fieldName = $1;
+
+ $fields{$fieldName} = $entity->GetFieldValue ($fieldName)->GetValue
+ . $newValue;
+ } # if
+
+ $self->_verbose ("Setting $fieldName to $fields{$fieldName}");
+
+ $status = $entity->SetFieldValue ($fieldName, $fields{$fieldName});
+
+ if ($status ne '') {
+ $self->_verbose ($status);
+
+ print $client "$status\n";
+ print $client "CQD Status: 1\n";
+
+ close $client;
+
+ return;
+ } # if
+ } # foreach
+
+ $self->_verbose ("Validating $id");
+
+ $status = $entity->Validate;
+
+ if ($status eq '') {
+ $self->_verbose ('Committing');
+ $entity->Commit;
+
+ print $client "Successfully updated $id\n";
+ print $client "CQD Status: 0\n";
+ } else {
+ $self->_verbose ('Reverting changes');
+ $entity->Revert;
+ print $client "$status\n";
+ print $client "CQD Status: 1\n";
+ } # if
+
+ close $client;
+
+ $self->_verbose ("Serviced requests from $host");
+
+ return;
+} # _serviceClient
+
+sub execute (%) {
+ my ($self, %request) = @_;
+
+ $self->connectToServer or croak 'Unable to connect to CQD Service';
+
+ return (-1, 'Unable to talk to server')
+ unless $self->{socket};
+
+ my ($status, @output) = (-1, ());
+
+ my $server = $self->{socket};
+
+ my $id = delete $request{id};
+
+ print $server "$id\n";
+
+ my $read;
+
+ foreach (keys %request) {
+ if ($request{$_}) {
+ print $server "$_=$request{$_}\n";
+ } else {
+ $read = 1;
+ print $server "$_\n";
+ } # if
+ } # foreach
+
+ print $server "end\n";
+
+ my ($response, %output);
+
+ while (defined ($response = <$server>)) {
+ if ($response =~ /CQD Status: (-*\d+)/) {
+ $status = $1;
+ last;
+ } # if
+
+ if ($read) {
+ chomp $response; chop $response if $response =~ /\r$/;
+
+ my ($field, $value) = split /\@\@/, $response;
+
+ $output{$field} = $value;
+ } else {
+ push @output, $response;
+ } # if
+ } # while
+
+ chomp @output unless $read;
+
+ $self->disconnectFromServer;
+
+ if ($status != 0 or $read == 0) {
+ return ($status, @output);
+ } else {
+ return ($status, %output);
+ } # if
+} # execute
+
+sub startServer (;$$$$$) {
+
+ require 'Clearquest.pm';
+
+ my ($self, $port, $username, $password, $db, $dbset) = @_;
+
+ $port ||= $OPTS{CQD_PORT};
+ $username ||= $OPTS{CQD_USERNAME};
+ $password ||= $OPTS{CQD_PASSWORD};
+ $db ||= $OPTS{CQD_DATABASE};
+ $dbset ||= $OPTS{CQD_DBSET};
+
+ # Create new socket to communicate to clients with
+ $self->{socket} = IO::Socket::INET->new(
+ Proto => 'tcp',
+ LocalPort => $port,
+ Listen => SOMAXCONN,
+ Reuse => 1
+ );
+
+ error "Could not create socket - $!", 1
+ unless $self->{socket};
+
+ # Connect to Clearquest database
+ $self->{session} = CQSession::Build ();
+
+ verbose "Connecting to $username\@$db";
+
+ $self->{session}->UserLogon ($username, $password, $db, $dbset);
+
+ # Announce ourselves
+ $self->_log ("CQD V$VERSION accepting clients at " . localtime);
+
+ # Now wait for an incoming request
+ LOOP:
+ my $client;
+
+ while ($client = $self->{socket}->accept) {
+ my $hostinfo = gethostbyaddr $client->peeraddr;
+ my $host = $hostinfo ? $hostinfo->name : $client->peerhost;
+
+ $self->_verbose ("$host is requesting service");
+
+ if ($self->getMultithreaded) {
+ $self->{server} = $$;
+
+ my $childpid;
+
+ $self->_debug ("Spawning child to handle request");
+
+ error "Can't fork: $!"
+ unless defined ($childpid = fork);
+
+ if ($childpid) {
+ $self->{pid} = $$;
+
+ $SIG{CHLD} = \&_funeral;
+ $SIG{HUP} = \&_endServer;
+ $SIG{USR2} = \&_restartServer;
+
+ $self->_debug ("Parent produced child [$childpid]");
+ } else {
+ # In child process - ServiceClient
+ $self->{pid} = $$;
+
+ $self->_debug ("Calling _serviceClient");
+ $self->_serviceClient ($host, $client);
+ $self->_debug ("Returned from _serviceClient - exiting...");
+
+ exit;
+ } # if
+ } else {
+ $self->_serviceClient ($host, $client);
+ } # if
+ } # while
+
+ # This works but I really don't like it. The parent should have looped back to
+ # the while statement thus waiting for the next client. But it doesn't seem to
+ # do that. Instead, when multithreaded, the child exits above and then the
+ # parent breaks out of the while loop. I'm not sure why this is happening.
+ # This goto fixes this up but it's sooooo ugly!
+ goto LOOP;
+} # startServer
+
+1;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<Carp>
+
+L<File::Basename|File::Basename>
+
+L<FindBin>
+
+L<IO::Socket|IO::Socket>
+
+L<Net::hostent|Net::hostent>
+
+L<POSIX>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ DateUtils
+ Display
+ GetConfig
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/DateUtils.pm">DateUtils</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/GetConfig.pm">GetConf</a><br>
+</blockquote>
+
+=end html
+
+=head1 SEE ALSO
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this module.
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2011, ClearSCM, Inc. All rights reserved.
+
+=cut
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: $RCSfile: LDAP.pm,v $
+# Revision: $Revision: 1.3 $
+# Description: The Clearquest LDAP Perl Module.
+# Author: Andrew@ClearSCM.com
+# Created: Fri Sep 22 09:21:18 CDT 2006
+# Modified: $Date: 2011/01/09 01:04:33 $
+# Language: perl
+#
+# (c) Copyright 2006, ClearSCM, Inc. all rights reserved
+#
+################################################################################
+use strict;
+use warnings;
+
+package LDAP;
+ use base "Exporter";
+
+ use Carp;
+ use OSDep;
+
+ my @MapFields = (
+ "CQ_EMAIL",
+ "CQ_FULLNAME",
+ "CQ_LOGIN_NAME",
+ "CQ_MISC_INFO",
+ "CQ_PHONE",
+ );
+
+ my @ScopeFields = (
+ "sub",
+ "one",
+ "base",
+ );
+
+ my @EXPORT = qw (
+ MapFields
+ ScopeFields
+ Validate
+ GetSettings
+ );
+
+ sub MapFields {
+ return @MapFields;
+ } # MAPFields
+
+ sub ScopeFields {
+ return @ScopeFields;
+ } # ScopeFields
+
+ sub Validate {
+ my (
+ $server,
+ $port,
+ $base,
+ $search_filter,
+ $account_attribute,
+ $search_for,
+ ) = @_;
+
+ eval { require Net::LDAP };
+
+ if ($@) {
+ return $FALSE, "Unable to load Net::LDAP. LDAP validation not possible.";
+ } # if
+
+ my $ldap = Net::LDAP->new ($server,
+ timeout => 2,
+ port => $port
+ );
+
+ return $FALSE, "Unable to connect to $server:$port" if !$ldap;
+
+ if (!$ldap->bind (version => 3)) {
+ return $FALSE, "Unable to bind to $server:$port";
+ } # if
+
+ my @attribute = ($account_attribute);
+ my $key = $search_filter;
+ $key =~ s/\%login\%/$search_for/;
+
+ my $result = $ldap->search (base => $base,
+ scope => "sub",
+ filter => $key,
+ attrs => @attribute,
+ );
+
+ $ldap->unbind;
+
+ my $entry = $result->entry;
+
+ if ($entry) {
+ my $value = $entry->get_value ($account_attribute);
+ return $TRUE, "Matched $key to LDAP";
+ } else {
+ return $FALSE, "Unable to find entry ($key)";
+ } # if
+ } # Validate
+
+ sub GetSettings {
+ my $dbset = shift;
+ my $admin_username = shift;
+ my $admin_passwords = shift;
+
+ my %LDAPSettings;
+
+ my $cmd = "installutil getldapinit $dbset $admin_username $admin_passwords";
+
+ my @output = `$cmd`;
+
+ carp "Unable to execute $cmd" if $?;
+
+ foreach (@output) {
+ chomp; chop if /\r/;
+
+ next if /^\*|^$/;
+
+ if (/Exit code (\d*)/) {
+ $? = $1;
+ next;
+ } # if
+
+ $LDAPSettings {ldapinit} .= "$_\n";
+ } # foreach
+
+ $cmd = "installutil getldapsearch $dbset $admin_username $admin_passwords";
+
+ @output = `$cmd`;
+
+ croak "Unable to execute $cmd" if $?;
+
+ foreach (@output) {
+ chomp; chop if /\r/;
+
+ next if /^\*|^$/;
+
+ if (/Exit code (\d*)/) {
+ $? = $1;
+ next;
+ } # if
+
+ $LDAPSettings {ldapsearch} .= "$_\n";
+ } # foreach
+
+ $cmd = "installutil getcqldapmap $dbset $admin_username $admin_passwords";
+
+ @output = `$cmd`;
+
+ croak "Unable to execute $cmd" if $?;
+
+ foreach (@output) {
+ chomp; chop if /\r/;
+
+ next if /^\*|^$/;
+
+ if (/Exit code (\d*)/) {
+ $? = $1;
+ next;
+ } # if
+
+ $LDAPSettings {cqldapmap} .= "$_\n";
+ } # foreach
+
+ return %LDAPSettings;
+ } # GetSettings
+1;
--- /dev/null
+=pod
+
+=head1 NAME $RCSfile: REST.pm,v $
+
+Clearquest REST client - Provide access to Clearquest via the REST interface
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 2.16 $
+
+=item Created
+
+Wed May 30 11:43:41 PDT 2011
+
+=item Modified
+
+$Date: 2013/03/26 02:24:01 $
+
+=back
+
+=head1 SYNOPSIS
+
+Provides a RESTful interface to Clearquest
+
+=head1 DESCRIPTION
+
+This module implements a simple interface to Clearquest. The backend uses REST
+however this module hides all of the ugly details of the REST implementation.
+Since REST is used, however, this module can be used by any normal Perl. See
+Perl Modules below of a list of Perl modules required.
+
+This module is object oriented so you need to instantiate an object. Be careful
+to make sure that you properly disconect from this object (See disconnect
+method).
+
+The methods exported are simple: add, delete, get, modify... In most cases you
+simply need to supply the table name and a hash of name value pairs to perform
+actions. Record hashes representing name/value parts for the fields in the
+records are returned to you.
+
+Here's an example of use:
+
+ use Clearquest;
+
+ my $cq;
+
+ END {
+ $cq->disconnect if $cq;
+ } # END
+
+ $cq = Clearquest->new (CQ_MODULE => 'rest');
+
+ $cq->connect;
+
+ my %record = $cq->get ('Project', 'Athena');
+
+ my %update = (
+ Deprecated => 1,
+ Projects => 'Island', '21331', 'Hera' ],
+ );
+
+ $cq->modify ('VersionInfo', '1.0', 'Modify', \%update);
+
+ if ($cq->error) {
+ die "Unable to modify record\n" . $cq->errmsg;
+ }
+
+=head2 NOTES
+
+Multiline text strings are limited to only 2000 characters by default. In order
+to expand this you need to change the cqrest.properties file in:
+
+C:\Program Files (x86)\IBM\RationalSDLC\common\CM\profiles\cmprofile\installedApps\dfltCell\TeamEAR.ear\cqweb.war\WEB-INF\classes
+
+on the web server. Multiline text strings can theoretically grow to 2 gig,
+however when set even as small as 10 meg REST messes up!
+
+=head1 METHODS
+
+The following methods are available:
+
+=cut
+
+package Clearquest::REST;
+
+use strict;
+use warnings;
+
+use File::Basename;
+use Carp;
+
+use CGI qw (escapeHTML);
+use Encode;
+use LWP::UserAgent;
+use HTTP::Cookies;
+use MIME::Base64;
+use REST::Client;
+use XML::Simple;
+
+use Clearquest;
+use GetConfig;
+use Utils;
+
+use parent 'Clearquest';
+
+our $VERSION = '$Revision: 2.16 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+=pod
+
+=head1 Options
+
+Options are keep in the cq.conf file in the etc directory. They specify the
+default options listed below. Or you can export the option name to the env(1) to
+override the defaults in cq.conf. Finally you can programmatically set the
+options when you call new by passing in a %parms hash. The items below are the
+key values for the hash.
+
+=for html <blockquote>
+
+=over
+
+=item CQ_SERVER
+
+The web host to contact with leading http://
+
+=item CQ_USERNAME
+
+User name to connect as (Default: From cq.conf)
+
+=item CQ_PASSWORD
+
+Password for CQ_USERNAME
+
+=item CQ_DATABASE
+
+Name of database to connect to (Default: From cq.conf)
+
+=item CQ_DBSET
+
+Database Set name (Default: From cq.conf)
+
+=back
+
+=cut
+
+our (%RECORDS, %FIELDS);
+
+# FieldTypes ENUM
+my $UNKNOWN = -1;
+my $STRING = 0;
+my $MULTILINE_STRING = 1;
+my $REFERENCE = 2;
+my $REFERENCE_LIST = 3;
+my $JOURNAL = 4;
+my $ATTACHMENT_LIST = 5;
+my $INT = 6;
+my $DATE_TIME = 7;
+my $DBID = 8;
+my $RECORD_TYPE = 9;
+
+sub _callREST ($$$;%) {
+ my ($self, $type, $url, $body, %parms) = @_;
+
+ # Set error and errmsg to no error
+ $self->error (0);
+ $self->{errmsg} = '';
+
+ # Upshift the call type as the calls are actually like 'GET' and not 'get'
+ $type = uc $type;
+
+ # We only support these call types
+ croak "Unknown call type \"$type\""
+ unless $type eq 'GET' or
+ $type eq 'POST' or
+ $type eq 'PATCH' or
+ $type eq 'OPTIONS' or
+ $type eq 'PUT' or
+ $type eq 'DELETE' or
+ $type eq 'HEAD';
+
+ # If the caller did not give us authorization then use the login member we
+ # already have in the object
+ unless ($parms{Authorization}) {
+ $parms{$_} = $self->{login}{$_} foreach (keys %{$self->{login}});
+ } # unless
+
+ # We need to use OSLC 2.0 for the conditional "is not null". So if we see a
+ # "oslc.where" in the URL then add OSLC-Core-Version => '2.0' to %parms.
+ if ($url =~ /oslc.where/) {
+ $parms{'OSLC-Core-Version'} = '2.0';
+ } # if
+
+ # Remove the host portion if any
+ $url =~ s/^http.*$self->{server}//;
+
+ # Call the REST call (Different calls have different numbers of parameters)
+ if ($type eq 'GET' or
+ $type eq 'DELETE' or
+ $type eq 'OPTIONS' or
+ $type eq 'HEAD') {
+ $self->{rest}->$type ($url, \%parms);
+ } else {
+ $self->{rest}->$type ($url, $body, \%parms);
+ } # if
+
+ return $self->error;
+} # _callREST
+
+sub _getRecordName ($) {
+ my ($self, $query) = @_;
+
+ $self->_callREST ('get', $query);
+
+ if ($self->error) {
+ $self->errmsg ("Unable to get record name for $query");
+
+ return;
+ } # if
+
+ my %record = %{XMLin ($self->{rest}->responseContent)};
+
+ return $record{element}{name};
+} # _getRecordName
+
+sub _getAttachmentList ($$) {
+ my ($self, $result, $fields) = @_;
+
+ croak ((caller(0))[3] . ' is not implemented');
+
+ return;
+} # _getAttachmentList
+
+sub _getInternalID ($$) {
+ my ($self, $table, $key) = @_;
+
+ my $query = "/cqweb/oslc/repo/$self->{dbset}/db/$self->{database}/record/?rcm.type=$table&";
+
+ $query .= "rcm.name=$key";
+
+ $self->_callREST ('get', $query);
+
+ unless ($self->error) {
+ my %result = %{XMLin ($self->{rest}->responseContent)};
+
+ return $result{entry}{id};
+ } else {
+ $self->errmsg ("Record not found (Table: $table, Key: \"$key\")");
+
+ return $self->errmsg;
+ } # unless
+} # _getInternalID
+
+sub _getRecord ($$@) {
+ my ($self, $table, $url, @fields) = @_;
+
+ $self->{fields} = [$self->_setFields ($table, @fields)];
+
+ $self->_callREST ('get', $url);
+
+ return if $self->error;
+
+ # Now parse the results
+ my %result = %{XMLin ($self->{rest}->responseContent)};
+
+ if ($result{entry}{content}{$table}) {
+ return $self->_parseFields ($table, %{$result{entry}{content}{$table}});
+ } elsif (ref \%result eq 'HASH') {
+ # The if test above will create an empty $result{entry}{content}. We need
+ # to delete that
+ delete $result{entry};
+
+ return $self->_parseFields ($table, %result);
+ } else {
+ return;
+ } # if
+} # _getRecord
+
+sub _getRecordID ($) {
+ my ($self, $table) = @_;
+
+ $self->records;
+
+ return $RECORDS{$table};
+} # _getRecordID
+
+sub _getRecordURL ($$;@) {
+ my ($self, $table, $url, @fields) = @_;
+
+ $self->{fields} = [$self->_setFields ($table, @fields)];
+
+ $self->error ($self->_callREST ('get', $url));
+
+ return if $self->error;
+
+ return $self->_parseFields ($table, %{XMLin ($self->{rest}->responseContent)});
+} # _getRecordURL
+
+sub _getReferenceList ($$) {
+ my ($self, $url, $field) = @_;
+
+ $self->error ($self->_callREST ('get', $url));
+
+ return if $self->error;
+
+ my %result = %{XMLin ($self->{rest}->responseContent)};
+
+ my @values;
+
+ # Need to find the field array here...
+ foreach my $key (keys %result) {
+ if (ref $result{$key} eq 'ARRAY') {
+ foreach (@{$result{$key}}) {
+ push @values, $$_{'oslc_cm:label'};
+ } # foreach
+
+ last;
+ } elsif (ref $result{$key} eq 'HASH' and $result{$key}{'oslc_cm:label'}) {
+ push @values, $result{$key}{'oslc_cm:label'};
+ } # if
+ } # foreach
+
+ return @values;
+} # _getReferenceList
+
+sub _parseCondition ($$) {
+ my ($self, $table, $condition) = @_;
+
+ # Parse simple conditions only
+ my ($field, $operator, $value);
+
+ if ($condition =~ /(\w+)\s*(==|=|!=|<>|<=|>=|<|>|in|is\s+null|is\s+not\s+null)\s*(.*)/i) {
+ $field = $1;
+ $operator = $2;
+ $value = $3;
+
+ if ($operator eq '==') {
+ $operator = '=';
+ } elsif ($operator eq '<>') {
+ $operator = '!=';
+ } elsif ($operator =~ /is\s+null/i) {
+ return "$field in [\"\"]";
+ } elsif ($operator =~ /is\s+not\s+null/i) {
+ return "$field in [*]";
+ } elsif ($operator =~ /in/i) {
+ return "$field in [$value]"
+ } # if
+ } # if
+
+ if ($operator eq '=' and $value =~ /^null$/i) {
+ return "$field in [\"\"]";
+ } elsif ($operator eq '!=' and $value =~ /^null$/i) {
+ return "$field in [*]";
+ } # if
+
+ # Trim quotes if any:
+ if ($value =~ /^\s*\'/) {
+ $value =~ s/^\s*\'//;
+ $value =~ s/\'\s*$//;
+ } elsif ($value =~ /^\s*\"/) {
+ $value =~ s/^\s*\"//;
+ $value =~ s/\"\s*$//;
+ } # if
+
+ # Trim leading and trailing whitespace
+ $value =~ s/^\s+//;
+ $value =~ s/\s+$//;
+
+ # Convert datetimes to Zulu
+ if ($self->fieldType ($table, $field) == $DATE_TIME and
+ $value !~ /\d{4}-\d{2}-\d{2}T\d{2}:\d{2}:\d{2}Z/) {
+ $value = Clearquest::_UTCTime ($value);
+ } # if
+
+ return "$field $operator \"$value\"";
+} # _parseCondition
+
+sub _parseConditional ($$) {
+ my ($self, $table, $condition) = @_;
+
+ return 'oslc_cm.query=' unless $condition;
+
+ my $parsedConditional;
+
+ # Special case when the condition is ultra simple
+ if ($condition !~ /(\w+)\s*(==|=|!=|<>|<|>|<=|>=|in|is\s+null|is\s+not\s+null)\s*(.*)/i) {
+ return "rcm.name=$condition";
+ } # if
+
+ # TODO: This section needs improvement to handle more complex conditionals
+ while () {
+ if ($condition =~ /(.+?)\s+(and|or)\s+(.+)/i) {
+ my $leftSide = $self->_parseCondition ($table, $1);
+
+ $parsedConditional .= "$leftSide $2 ";
+ $condition = $3;
+ } else {
+ $parsedConditional .= $self->_parseCondition ($table, $condition);
+
+ last;
+ } # if
+ } # while
+
+ # TODO: How would this work if we have a condition like 'f1 = "value" and
+ # f2 is not null'?
+ if ($parsedConditional =~ /in \[\*\]/) {
+ return "oslc.where=$parsedConditional";
+ } else {
+ return "oslc_cm.query=$parsedConditional";
+ } # if
+} # _parseConditional
+
+sub _parseFields ($%) {
+ my ($self, $table, %record) = @_;
+
+ foreach my $field (keys %record) {
+ if ($field =~ /:/ or
+ $field eq 'xmlns' or
+ grep {/^$field$/} @{$self->{fields}} == 0) {
+ delete $record{$field};
+
+ next;
+ } # if
+
+ my $fieldType = $self->fieldType ($table, $field);
+
+ if (ref $record{$field} eq 'HASH') {
+ if ($fieldType == $REFERENCE) {
+ $record{$field} = $record{$field}{'oslc_cm:label'};
+ } elsif ($fieldType == $REFERENCE_LIST) {
+ my @values = $self->_getReferenceList ($record{$field}{'oslc_cm:collref'}, $field);
+
+ $record{$field} = \@values;
+ } elsif ($fieldType == $ATTACHMENT_LIST) {
+ my @attachments = $self->_getAttachmentList ($record{$field}{'oslc_cm:collref'}, $field);
+
+ $record{$field} = \@attachments;
+ } elsif ($fieldType == $RECORD_TYPE) {
+ $record{$field} = $record{$field}{'oslc_cm:label'};
+ } elsif (!%{$record{$field}}) {
+ $record{$field} = undef;
+ } # if
+ } # if
+
+ $record{$field} ||= '' if $self->{emptyStringForUndef};
+
+ if ($fieldType == $DATE_TIME) {
+ $record{$field} = Clearquest::_UTC2Localtime $record{$field};
+ } # if
+ } # foreach
+
+ return %record;
+} # _parseFields
+
+sub _parseRecordDesc ($) {
+ my ($self, $table) = @_;
+
+ # Need to get fieldType info
+ my $recordID = $self->_getRecordID ($table);
+
+ return unless $recordID;
+
+ my $url = "$self->{uri}/record-type/$recordID";
+
+ $self->_callREST ('get', $url);
+
+ return if $self->error;
+
+ my %result = %{XMLin ($self->{rest}->responseContent)};
+
+ # Reach in deep for field definitions
+ my %fields = %{$result{element}{complexType}{choice}{element}};
+
+ foreach (keys %fields) {
+ if ($fields{$_}{type} and $fields{$_}{type} eq 'cqf:reference') {
+ $FIELDS{$table}{$_}{FieldType} = $REFERENCE;
+ $FIELDS{$table}{$_}{References} = $self->_getRecordName ($fields{$_}{'cq:refURI'});
+ } elsif ($fields{$_}{type} and $fields{$_}{type} eq 'cqf:multilineString') {
+ $FIELDS{$table}{$_}{FieldType} = $MULTILINE_STRING;
+ } elsif ($fields{$_}{simpleType}) {
+ if ($fields{$_}{simpleType}{restriction}{base}) {
+ if ($fields{$_}{simpleType}{restriction}{base} eq 'string') {
+ $FIELDS{$table}{$_}{FieldType} = $STRING;
+ } elsif ($fields{$_}{simpleType}{union}{simpleType}[0]{restriction}{base} eq 'string') {
+ $FIELDS{$table}{$_}{FieldType} = $STRING;
+ } else {
+ $FIELDS{$table}{$_}{FieldType} = $UNKNOWN;
+ } # if
+ } elsif ($fields{$_}{simpleType}{union}{simpleType}[0]{restriction}{base} eq 'string') {
+ $FIELDS{$table}{$_}{FieldType} = $STRING;
+ } elsif ($fields{$_}{simpleType}{union}{simpleType}[0]{restriction}{base} eq 'cqf:integer') {
+ $FIELDS{$table}{$_}{FieldType} = $INT;
+ } else {
+ $FIELDS{$table}{$_} = $UNKNOWN;
+ } # if
+ } elsif ($fields{$_}{complexType} and $fields{$_}{'cq:refURI'}) {
+ $FIELDS{$table}{$_}{FieldType} = $REFERENCE_LIST;
+ $FIELDS{$table}{$_}{References} = $self->_getRecordName ($fields{$_}{'cq:refURI'});
+ } elsif ($fields{$_}{complexType} and
+ $fields{Symptoms}{complexType}{sequence}{element}{simpleType}{union}{simpleType}[1]{restriction}{base} eq 'string') {
+ $FIELDS{$table}{$_}{FieldType} = $MULTILINE_STRING;
+ } elsif ($fields{$_}{type} and $fields{$_}{type} eq 'cqf:journal') {
+ $FIELDS{$table}{$_}{FieldType} = $JOURNAL;
+ } elsif ($fields{$_}{type} and $fields{$_}{type} eq 'cqf:attachmentList') {
+ $FIELDS{$table}{$_}{FieldType} = $ATTACHMENT_LIST;
+ } elsif ($fields{$_}{type} and $fields{$_}{type} eq 'cqf:integer') {
+ $FIELDS{$table}{$_}{FieldType} = $INT;
+ } elsif ($fields{$_}{type} and $fields{$_}{type} eq 'cqf:dateTime') {
+ $FIELDS{$table}{$_}{FieldType} = $DATE_TIME;
+ } elsif ($fields{$_}{type} and $fields{$_}{type} eq 'cqf:recordType') {
+ $FIELDS{$table}{$_}{FieldType} = $RECORD_TYPE;
+ } else {
+ $FIELDS{$table}{$_}{FieldType} = $UNKNOWN;
+ } # if
+
+ if ($fields{$_}{'cq:systemOwned'} and $fields{$_}{'cq:systemOwned'} eq 'true') {
+ $FIELDS{$table}{$_}{SystemField} = 1;
+ } else {
+ $FIELDS{$table}{$_}{SystemField} = 0;
+ } # if
+ } # foreach
+
+ return;
+} # _parseRecordDesc
+
+sub _isSystemField ($$) {
+ my ($self, $table, $fieldName) = @_;
+
+ if ($FIELDS{$table}) {
+ # If we already have this fieldType just return it
+ if (defined $FIELDS{$table}{$fieldName}) {
+ return $FIELDS{$table}{$fieldName}{SystemField};
+ } else {
+ return 0;
+ } # if
+ } # if
+
+ $self->_parseRecordDesc ($table);
+
+ if (defined $FIELDS{$table}{$fieldName}) {
+ return $FIELDS{$table}{$fieldName}{SystemField};
+ } else {
+ return 0;
+ } # if
+} # _isSystemField
+
+sub _setFields ($@) {
+ my ($self, $table, @fields) = @_;
+
+ # Cause %FIELDS to be expanded for $table
+ $self->_parseRecordDesc ($table);
+
+ unless (@fields) {
+ foreach ($self->fields ($table)) {
+ unless ($self->{returnSystemFields}) {
+ next if $FIELDS{$table}{$_}{SystemField}
+ } # unless
+
+ push @fields, $_;
+ } # foreach
+ } # unless
+
+ push @fields, 'dbid' unless grep { /dbid/ } @fields;
+
+ return @fields;
+} # _setFields
+
+sub _setFieldValue ($$$) {
+ my ($self, $table, $fieldName, $fieldValue) = @_;
+
+ return if $self->_isSystemField ($table, $fieldName);
+
+ my $xml .= "<$fieldName>";
+
+ my $fieldType = $self->fieldType ($table, $fieldName);
+
+ if ($fieldType == $STRING or
+ $fieldType == $MULTILINE_STRING or
+ $fieldType == $INT or
+ $fieldType == $DATE_TIME) {
+ # Fix MULTILINE_STRINGs
+ if ($fieldType == $MULTILINE_STRING and ref $fieldValue eq 'ARRAY') {
+ chomp @{$fieldName};
+
+ $fieldValue= join "\n", @$fieldValue;
+ } # if
+
+ $xml .= escapeHTML $fieldValue;
+ } elsif ($fieldType == $REFERENCE) {
+ my $tableReferenced = $self->fieldReference ($table, $fieldName);
+
+ if ($tableReferenced) {
+ $xml .= $self->_getInternalID ($tableReferenced, $fieldValue);
+ } else {
+ $self->error (600);
+ $self->errmsg ("Could not determine reference for $fieldName");
+
+ return;
+ } # if
+ } elsif ($fieldType == $REFERENCE_LIST) {
+ # We'll allow either an array reference or a single value, which we will
+ # turn into an array
+ my @values;
+
+ @values = ref $fieldValue eq 'ARRAY' ? @$fieldValue
+ : ($fieldValue);
+
+ my $tableReferenced = $self->fieldReference ($table, $fieldName);
+
+ unless ($tableReferenced) {
+ $self->error (600);
+ $self->errmsg ("Could not determine reference for $fieldName");
+
+ return;
+ } # if
+
+ foreach (@values) {
+ my $internalID = $self->_getInternalID ($tableReferenced, $_);
+
+ if ($internalID) {
+ $xml .= "<value rdf:resource=\"$internalID\" oslc_cm:label=\"$_\"/>\n";
+ } else {
+ $self->error (600);
+ $self->errmsg ("Could not find a valid/active $tableReferenced with a key of \"$_\"");
+
+ return
+ } # if
+ } # foreach
+ } else {
+ croak "Unable to handle field $fieldName fieldType: " . $self->fieldTypeName ($table, $fieldName);
+ } # if
+
+ $xml .= "</$fieldName>\n";
+
+ return $xml;
+} # _setFieldValue
+
+sub _startXML ($) {
+ my ($table) = @_;
+
+ my $xml = << "XML";
+<?xml version="1.0" encoding="UTF-8"?>
+<$table
+ xmlns="http://www.ibm.com/xmlns/prod/rational/clearquest/1.0/"
+ xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
+ xmlns:dc="http://purl.org/dc/terms/"
+ xmlns:oslc_cm="http://open-services.net/xmlns/cm/1.0/">
+XML
+
+ return $xml
+} # _startXML
+
+sub add ($$;@) {
+ my ($self, $table, $record, @ordering) = @_;
+
+=pod
+
+=head2 add ($table, %record)
+
+Adds a %record to $table.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $table
+
+Table to add a record to (e.g. 'Defect')
+
+=item $values
+
+Hash reference of name/value pairs for the insertion
+
+=item @ordering
+
+Array containing field names that need to be processed in order. Not all fields
+mentioned in the $values hash need be mentioned here. If you have fields that
+must be set in a particular order you can mention them here. So, if you're
+adding the Defect record, but you need Project set before Platform, you need
+only pass in an @ordering of qw(Project Platform). They will be done first, then
+all of the rest of the fields in the $values hash. If you have no ordering
+dependencies then you can simply omit @ordering.
+
+Note that the best way to determine if you have an ordering dependency try using
+a Clearquest client and note the order that you set fields in. If at anytime
+setting one field negates another field via action hook code then you have just
+figured out that this field needs to be set before the file that just got
+negated.
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $errmsg
+
+Error message (if any)
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my %record = %$record;
+ my $xml = _startXML $table;
+ my $uri = $self->{uri} . '/record';
+
+ # First process all fields in the @ordering, if specified
+ $xml .= $self->_setFieldValue ($table, $_, $record{$_}) foreach (@ordering);
+
+ foreach my $field (keys %record) {
+ next if InArray $field, @ordering;
+
+ $xml .= $self->_setFieldValue ($table, $field, $record{$field});
+ } # foreach
+
+ $xml .= "</$table>";
+
+ $self->_callREST ('post', $uri, $xml);
+
+ # Get the DBID of the newly created record
+ if ($self->{rest}{_res}{_headers}{location} =~ /-(\d+)$/) {
+ return $1;
+ } else {
+ return;
+ } # if
+} # add
+
+sub connect (;$$$$) {
+ my ($self, $username, $password, $database, $dbset) = @_;
+
+=pod
+
+=head2 connect (;$$$$)
+
+This method doesn't really connect but is included to be similar to the
+Clearquest::connect method. It does set any of the username, password,
+database and/or dbset members
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $username
+
+Username to use to connect to the database
+
+=item $password
+
+Password to use to connect to the database
+
+=item $database
+
+Clearquest database to connect to
+
+=item $dbset
+
+Database set to connect to (Default: Connect to the default dbset)
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item 1
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ if (ref $username eq 'HASH') {
+ my %opts = %$username;
+
+ $self->{username} = delete $opts{CQ_USERNAME};
+ $self->{password} = delete $opts{CQ_PASSWORD};
+ $self->{database} = delete $opts{CQ_DATABASE};
+ $self->{dbset} = delete $opts{CQ_DBSET};
+ } else {
+ $self->{username} = $username if $username;
+ $self->{password} = $password if $password;
+ $self->{database} = $database if $database;
+ $self->{dbset} = $dbset if $dbset;
+ } # if
+
+ # Set URI in case anything changed
+ $self->{uri} = "/cqweb/oslc/repo/$self->{dbset}/db/$self->{database}";
+ $self->{loggedin} = 1;
+
+ return 1;
+} # connect
+
+sub connected () {
+ my ($self) = @_;
+
+=pod
+
+=head2 connected ()
+
+Returns 1 if we are currently connected to Clearquest
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item 1 if logged in - 0 if not
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{loggedin};
+} # connected
+
+sub database () {
+ my ($self) = @_;
+
+=pod
+
+=head2 database
+
+Returns the current database (or the database that would be used)
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item database
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{database};
+} # database
+
+sub dbset () {
+ my ($self) = @_;
+
+=pod
+
+=head2 dbset
+
+Returns the current dbset (or the dbset that would be used)
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item dbset
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{dbset};
+} # dbset
+
+sub dbsets () {
+ croak ((caller(0))[3] . ' is not implemented');
+} # dbsets
+
+sub delete ($$) {
+ my ($self, $table, $key) = @_;
+
+=pod
+
+=head2 delete ($table, $key)
+
+Deletes a %record from $table.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $table
+
+Table from which to delete a record from (e.g. 'Defect')
+
+=item $key
+
+Key of the record to delete
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $errmsg
+
+Error message (if any)
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my $query = $self->_getInternalID ($table, $key);
+
+ # Need to remove $self->{server} from beginning of $query
+ $query =~ s/^http.*$self->{server}//;
+
+ $self->_callREST ('delete', $query);
+
+ return $self->errmsg;
+} # delete
+
+sub DESTROY () {
+ my ($self) = @_;
+
+ # Attempt to delete session if we still have a rest object. Note that during
+ # global destruction (like when you die or exit), the ordering of destruction
+ # is unpredictable so we might not succeed.
+ return unless $self->{rest};
+
+ # Delete session - ignore error as there's really nothing we can do if this
+ # fails.
+ $self->_callREST ('delete', '/cqweb/oslc/session/');
+
+ croak "Unable to release REST session in destructor" if $self->error;
+
+ return;
+} # DESTROY
+
+sub disconnect () {
+ my ($self) = @_;
+
+=pod
+
+=head2 disconnect ()
+
+Disconnects from REST. Note you should take care to call disconnect or use undef
+to undefine your instantiated Clearquest::REST object. If your script dies or
+exits without disconnecting you may cause web sessions to remain. You might try
+something like:
+
+ use Clearquest::REST;
+
+ my $cq = Clearquest::REST->new;
+
+ END {
+ $cq->disconnect if $cq;
+ } # END
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item nothing
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $error
+
+Error number (if any)
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return unless $self->{rest};
+
+ $self->_callREST ('delete', '/cqweb/oslc/session/');
+
+ return $self->error;
+} # disconnect
+
+sub errmsg (;$) {
+ my ($self, $errmsg) = @_;
+
+=pod
+
+=head2 errmsg ($errmsg)
+
+Returns the last error message. Optionally sets the error message if specified.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $errmsg
+
+Error message to set
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $errmsg
+
+Last error message
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ if ($errmsg) {
+ $self->{errmsg} = $errmsg;
+ } else {
+ # User defined errors are in the 600 series. If we have a user defined
+ # error and the caller did not supply us an errmsg to set then they want
+ # the user defined error we set so just return that.
+ if ($self->{responseCode} >= 600) {
+ return $self->{errmsg};
+ } else {
+ my $response = $self->response;
+
+ if ($response and $response ne '') {
+ my %xml = %{XMLin ($self->response)};
+
+ if ($xml{Error}{message}) {
+ $self->{errmsg} = $xml{Error}{message};
+ } elsif (ref $xml{message} ne 'HASH' and $xml{message}) {
+ $self->{errmsg} = $xml{message};
+ } else {
+ $self->{errmsg} = 'Unknown error';
+ } # if
+ } else {
+ $self->{errmsg} = '';
+ } # if
+ } # if
+ } # if
+
+ return $self->{errmsg};
+} # errmsg
+
+sub error (;$) {
+ my ($self, $error) = @_;
+
+=pod
+
+=head2 error ($error)
+
+Returns the last error number. Optional set the error number if specified
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $error
+
+Error number to set
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $error
+
+Last error
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+
+ if (defined $error) {
+ $self->{responseCode} = $error;
+ } else {
+ # If the user has not yet called any underlying REST functionality yet (for
+ # example, they could have called the find method but have not asked for the
+ # $nbrRecs) then we cannot call $self->{rest}->responseCode because the
+ # REST::Client object has not been instantiated yet. So we'll return no
+ # error.
+ if ($self->{rest}{_res}) {
+ $self->{responseCode} = $self->{rest}->responseCode;
+ } else {
+ $self->{responseCode} = 0;
+ } # if
+ } # if
+
+ return 0 if $self->{responseCode} >= 200 and $self->{responseCode} < 300;
+ return $self->{responseCode};
+} # error
+
+sub fields ($) {
+ my ($self, $table) = @_;
+
+=pod
+
+=head2 fields ($table)
+
+Returns an array of the fields in a table
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $table
+
+Table to return field info from.
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item @fields
+
+Array of the fields names for $table
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my $recordID = $self->_getRecordID ($table);
+
+ return unless $recordID;
+
+ my $url = "$self->{uri}/record-type/$recordID";
+
+ $self->_callREST ('get', $url);
+
+ return if $self->error;
+
+ my %result = %{XMLin ($self->{rest}->responseContent)};
+
+ my @fields = keys %{$result{element}{complexType}{choice}{element}};
+
+ return @fields;
+} # fields
+
+sub fieldType ($$) {
+ my ($self, $table, $fieldName) = @_;
+
+=pod
+
+=head2 fieldType ($table, $fieldname)
+
+Returns the field type for the $table, $fieldname combination.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $table
+
+Table to return field type from.
+
+=item $fieldname
+
+Fieldname to return the field type from.
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $fieldType
+
+Fieldtype enum
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ # If we've already computed the fieldTypes for the fields in this table then
+ # return the value
+ if ($FIELDS{$table}) {
+ # If we already have this fieldType just return it
+ if (defined $FIELDS{$table}{$fieldName}) {
+ return $FIELDS{$table}{$fieldName}{FieldType};
+ } else {
+ return $UNKNOWN
+ } # if
+ } # if
+
+ $self->_parseRecordDesc ($table);
+
+ if (defined $FIELDS{$table}{$fieldName}) {
+ return $FIELDS{$table}{$fieldName}{FieldType};
+ } else {
+ return $UNKNOWN
+ } # if
+} # fieldType
+
+sub fieldReference ($$) {
+ my ($self, $table, $fieldName) = @_;
+
+=pod
+
+=head2 fieldReference ($table, $fieldname)
+
+Returns the name of the table this reference or reference list field references
+or undef if this is not a reference or reference list field.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $table
+
+Table to return field reference from.
+
+=item $fieldname
+
+Fieldname to return the field type from.
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $fieldType
+
+Name of table this reference or reference list field references or undef if
+this is not a reference or reference list field.
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ # If we've already computed the fieldTypes for the fields in this table then
+ # return the value
+ return $FIELDS{$table}{$fieldName}{References} if $FIELDS{$table};
+
+ $self->_parseRecordDesc ($table);
+
+ return $FIELDS{$table}{$fieldName}{References};
+} # fieldReference
+
+sub find ($;$@) {
+ my ($self, $table, $condition, @fields) = @_;
+
+=pod
+
+=head2 find ($;$@)
+
+Find records in $table. You can specify a $condition and which fields you wish
+to retrieve. Specifying a smaller set of fields means less data transfered and
+quicker retrieval so only retrieve the fields you really need.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $table
+
+Name of the table to search
+
+=item $condition
+
+Condition to use. If you want all records then pass in undef. Only simple
+conditions are supported. You can specify compound conditions (e.g. field1 ==
+'foo' and field1 == 'bar' or field2 is not null). No parenthesizing is
+supported (yet).
+
+=item @fields
+
+An array of fieldnames to retrieve
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $result or ($result, $nbrRecs)
+
+Internal structure to be used with getNext. If in an array context then $nbrRecs
+is also returned.
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $self->{url} = "$self->{uri}/record/?rcm.type=$table&"
+ . $self->_parseConditional ($table, $condition);
+
+ @fields = $self->_setFields ($table, @fields);
+
+ # Remove dbid for find
+ @fields = grep { $_ ne 'dbid' } @fields;
+
+ if (@fields) {
+ $self->{url} .= "&oslc_cm.properties=";
+ $self->{url} .= join ',', @fields;
+ } # if
+
+ # Save some fields for getNext
+ $self->{fields} = \@fields;
+ $self->{table} = $table;
+
+ $self->{url} .= "&oslc_cm.pageSize=1";
+
+ return $self->{url} unless wantarray;
+
+ # If the user wants an array then he wants ($reesult, $nbrRecs) and so we need
+ # to go out and get that info.
+ $self->_callREST ('get', $self->{url});
+
+ return (undef, 0) if $self->error;
+
+ # Now parse the results
+ my %result = %{XMLin ($self->{rest}->responseContent)};
+
+ return ($self->{url}, $result{'oslc_cm:totalCount'}{content});
+} # find
+
+sub get ($$;@) {
+ my ($self, $table, $key, @fields) = @_;
+
+=pod
+
+=head2 get ($table, $key, @fields)
+
+Retrieve records from $table matching $key. Note $key can be a condition (e.g.
+Project = 'Athena'). Return back @fields. If @fields is not specified then all
+fields are returned.
+
+Warning: Some Clearquest records are large. It's always better and faster to
+return only the fields that you need.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $table
+
+Table to get records from (e.g. 'Defect')
+
+=item $key
+
+Key to use to get the record. Key is the field that is designated to be the key
+for the record.
+
+=item @fields
+
+An array of field names to return. It's usually better to specify only those
+fields that you need.
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item %record
+
+An hash representing the qualifying record.
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my $url = "$self->{uri}/record/?rcm.type=$table&rcm.name=$key";
+
+ if (@fields) {
+ $url .= "&oslc_cm.properties=";
+ $url .= 'dbid,' unless grep { /dbid/i } @fields;
+ $url .= join ',', @fields;
+ } # if
+
+ return $self->_getRecord ($table, $url, @fields);
+} # get
+
+sub getDBID ($$;@) {
+ my ($self, $table, $dbid, @fields) = @_;
+
+=pod
+
+=head2 get ($table, $key, @fields)
+
+Retrieve records from $table matching $key. Note $key can be a condition (e.g.
+Project = 'Athena'). Return back @fields. If @fields is not specified then all
+fields are returned.
+
+Warning: Some Clearquest records are large. It's always better and faster to
+return only the fields that you need.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $table
+
+Table to get records from (e.g. 'Defect')
+
+=item $key
+
+Key to use to get the record. Key is the field that is designated to be the key
+for the record.
+
+=item @fields
+
+An array of field names to return. It's usually better to specify only those
+fields that you need.
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item %record
+
+An hash representing the qualifying record.
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my $url = "$self->{uri}/record/";
+ $url .= $self->_getRecordID ($table);
+ $url .= '-';
+ $url .= $dbid;
+
+ if (@fields) {
+ $url .= "?oslc_cm.properties=";
+ $url .= 'dbid,' unless grep { /dbid/i } @fields;
+ $url .= join ',', @fields;
+ } # if
+
+ return $self->_getRecord ($table, $url);
+} # getDBID
+
+sub getDynamicList () {
+ croak ((caller(0))[3] . ' is not implemented');
+} # getDynamicList
+
+sub getNext ($) {
+ my ($self, $result) = @_;
+
+=pod
+
+=head2 getNext ($)
+
+Return the next record that qualifies from a preceeding call to the find method.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $result
+
+The $result returned from find.
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item %record
+
+Hash of name/value pairs for the @fields specified to find.
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return unless $self->{url};
+
+ my $url = $self->{url};
+
+ $self->_callREST ('get', $url);
+
+ return if $self->error;
+
+ # Now parse the results
+ my %result = %{XMLin ($self->{rest}->responseContent)};
+
+ # Get the next link
+ undef $self->{url};
+
+ if (ref $result{link} eq 'ARRAY') {
+ foreach (@{$result{link}}) {
+ if ($$_{rel} eq 'next') {
+ ($self->{url}) = ($$_{href} =~ /^http.*$self->{server}(.*)/);
+
+ last;
+ } # if
+ } # foreach
+ } # if
+
+ my %record;
+
+ if (ref $result{entry}{content}{$self->{table}} eq 'HASH') {
+ %record = $self->_parseFields ($self->{table}, %{$result{entry}{content}{$self->{table}}});
+ } elsif (ref $result{entry} eq 'HASH') {
+ if ($result{entry}{id}) {
+ %record = $self->_getRecordURL ($self->{table}, $result{entry}{id}, @{$self->{fields}});
+ } # if
+ } # if
+
+ # Get dbid
+ if ($result{entry}{link}{href} =~ /-(\d+)$/) {
+ $record{dbid} = $1;
+ } # if
+
+ return %record;
+} # getNext
+
+sub key ($$) {
+ my ($self, $table, $dbid) = @_;
+
+=pod
+
+=head2 key ($$)
+
+Return the key of the record given a $dbid
+
+NOTE: Not supported in REST implementation.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $table
+
+Name of the table to lookup
+
+=item $dbid
+
+Database ID of the record to retrieve
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item key
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ croak "The method key is not support in the REST interface";
+} # key
+
+sub modify ($$$$;@) {
+ my ($self, $table, $key, $action, $values, @ordering) = @_;
+
+=pod
+
+=head2 modify ($table, $key, $action, $values, @ordering)
+
+Updates records from $table matching $key.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $table
+
+Table to modify records (e.g. 'Defect')
+
+=item $key
+
+The $key of the record to modify.
+
+=item $action
+
+Action to use for modification (Default: Modify). You can use this to change
+state for stateful records.
+
+=item $values
+
+Hash reference containing name/value that have the new values for the fields
+
+=item @ordering
+
+Array containing field names that need to be processed in order. Not all fields
+mentioned in the $values hash need be mentioned here. If you have fields that
+must be set in a particular order you can mention them here. So, if you're
+modifying the Defect record, but you need Project set before Platform, you need
+only pass in an @ordering of qw(Project Platform). They will be done first, then
+all of the rest of the fields in the $values hash. If you have no ordering
+dependencies then you can simply omit @ordering.
+
+Note that the best way to determine if you have an ordering dependency try using
+a Clearquest client and note the order that you set fields in. If at anytime
+setting one field negates another field via action hook code then you have just
+figured out that this field needs to be set before the file that just got
+negated.
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $errmsg
+
+Error message (if any)
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my %values = %$values;
+ my $xml = _startXML $table;
+
+ $action ||= 'Modify';
+
+ my $query = $self->_getInternalID ($table, $key);
+
+ # Remove host portion
+ $query =~ s/^http.*$self->{server}//;
+
+ # Add on action
+ $query .= "?rcm.action=$action";
+
+ # First process all fields in the @ordering, if specified
+ $xml .= $self->_setFieldValue ($table, $_, $values{$_}) foreach (@ordering);
+
+ foreach my $field (keys %values) {
+ next if InArray $field, @ordering;
+
+ $xml .= $self->_setFieldValue ($table, $field, $values{$field});
+ } # foreach
+
+ $xml .= "</$table>";
+
+ $self->_callREST ('put', $query, $xml);
+
+ return $self->errmsg;
+} # modify
+
+sub modifyDBID ($$$$;@) {
+ my ($self, $table, $dbid, $action, $values, @ordering) = @_;
+
+=pod
+
+=head2 modifyDBID ($table, $dbid, $action, %update)
+
+Updates records from $table matching $dbid.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $table
+
+Table to modify records (e.g. 'Defect')
+
+=item $dbid
+
+The $dbid of the record to modify.
+
+=item $action
+
+Action to use for modification (Default: Modify). You can use this to change
+state for stateful records.
+
+=item $values
+
+Hash reference containing name/value that have the new values for the fields
+
+=item @ordering
+
+Array containing field names that need to be processed in order. Not all fields
+mentioned in the $values hash need be mentioned here. If you have fields that
+must be set in a particular order you can mention them here. So, if you're
+modifying the Defect record, but you need Project set before Platform, you need
+only pass in an @ordering of qw(Project Platform). They will be done first, then
+all of the rest of the fields in the $values hash. If you have no ordering
+dependencies then you can simply omit @ordering.
+
+Note that the best way to determine if you have an ordering dependency try using
+a Clearquest client and note the order that you set fields in. If at anytime
+setting one field negates another field via action hook code then you have just
+figured out that this field needs to be set before the file that just got
+negated.
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $errmsg
+
+Error message (if any)
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my %values = %$values;
+ my $xml = _startXML $table;
+
+ $action ||= 'Modify';
+
+ my $query = "$self->{uri}/record/";
+ $query .= $self->_getRecordID ($table);
+ $query .= '-';
+ $query .= $dbid;
+
+ # Add on action
+ $query .= "?rcm.action=$action";
+
+ # First process all fields in the @ordering, if specified
+ $xml .= $self->_setFieldValue ($table, $_, $values{$_}) foreach (@ordering);
+
+ foreach my $field (keys %values) {
+ next if InArray $field, @ordering;
+
+ $xml .= $self->_setFieldValue ($table, $field, $values{$field});
+ } # foreach
+
+ $xml .= "</$table>";
+
+ $self->_callREST ('put', $query, $xml);
+
+ return $self->errmsg;
+} # modifyDBID
+
+sub new (;%) {
+ my ($class, $self) = @_;
+
+=pod
+
+=head2 new (%parms)
+
+Instantiate a new REST object. You can override the standard options by passing
+them in as a hash in %parms.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item %parms
+
+Hash of overriding options
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item REST object
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $self->{server} ||= $Clearquest::OPTS{CQ_SERVER};
+
+ $$self{base_url} = "$self->{server}/cqweb/oslc",
+ $$self{uri} = "/cqweb/oslc/repo/$self->{dbset}/db/$self->{database}",
+ $$self{login} = {
+# 'OSLC-Core-Version' => '2.0',
+ Accept => 'application/xml',
+ Authorization => 'Basic '
+ . encode_base64 "$self->{username}:$self->{password}",
+ };
+
+ bless $self, $class;
+
+ # We create this UserAgent and Cookie Jar so we can set cookies to be
+ # remembered and passed back and forth automatically. By doing this we re-use
+ # the JSESSIONID cookie we allows us to reuse our login and to dispose of the
+ # login session properly when we are destroyed.
+ my $userAgent = LWP::UserAgent->new;
+
+ # Set the cookie jar to use in-memory cookie management, cookies can be
+ # persisted to disk, see HTTP::Cookies for more info.
+ $userAgent->cookie_jar (HTTP::Cookies->new);
+
+ $self->{rest} = REST::Client->new (
+ host => $self->{server},
+ timeout => 15,
+ follow => 1,
+ useragent => $userAgent,
+ );
+
+ return $self;
+} # new
+
+sub records () {
+ my ($self) = @_;
+
+=pod
+
+=head2 records ()
+
+Returns a hash of all records and their record numbers
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item nothing
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item %records
+
+Hash of records and their record numbers
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return if %RECORDS;
+
+ my $url = "$self->{uri}/record-type/";
+
+ $self->_callREST ('get', $url);
+
+ unless ($self->error) {
+ my %result = %{XMLin ($self->{rest}->responseContent)};
+
+ foreach my $uri (keys %{$result{entry}}) {
+ my ($recordID) = ($uri =~ /\/(\d+)/);
+
+ $RECORDS{$result{entry}{$uri}{title}} = $recordID;
+ } # foreach
+ } # unless
+
+ return %RECORDS;
+} # records
+
+sub response () {
+ my ($self) = @_;
+
+=pod
+
+=head2 response ()
+
+Returns the response content
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item nothing
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $respondContent
+
+Response content from the last REST call
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{rest}->responseContent;
+} # response
+
+sub username () {
+ my ($self) = @_;
+
+=pod
+
+=head2 username
+
+Returns the current username (or the username that would be used)
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item username
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{username};
+} # username
+
+1;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<Carp>
+
+L<Encode>
+
+L<File::Basename|File::Basename>
+
+L<HTTP::Cookies|HTTP::Cookies>
+
+L<LWP::UserAgent|LWP::UserAgent>
+
+L<MIME::Base64|MIME::Base64>
+
+L<REST::Client|REST::Client>
+
+L<XML::Simple|XML::Simple>
+
+L<MIME::Base64|MIME::Base64>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ GetConfig
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/GetConfig.pm">GetConf</a><br>
+</blockquote>
+
+=end html
+
+=head1 SEE ALSO
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this module.
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2012, ClearSCM, Inc. All rights reserved.
+
+=cut
\ No newline at end of file
--- /dev/null
+=pod
+
+=head1 NAME $RCSfile: Server.pm,v $
+
+Clearquest Server - Provide access to Clearquest database
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 2.6 $
+
+=item Created
+
+Monday, October 10, 2011 5:02:07 PM PDT
+
+=item Modified
+
+$Date: 2013/03/14 23:13:33 $
+
+=back
+
+=head1 SYNOPSIS
+
+Provides an interface to the Clearquest database over the network.
+
+This library implements both the daemon portion of the server and the client
+API.
+
+=head1 DESCRIPTION
+
+The server allows both read and write access to a Clearquest database as defined
+in cq.conf file. Note the username/password must be of a user who can write to
+the Clearquest database for write access to succeed.
+
+A hash is passed into to the execute method, which the client should use to talk
+to the server, that describes relatively simple protocol to tell the server what
+action to perform. In both the read case and the read/write case a field named
+id should be defined that has a value of "<record>=<id>" (e.g.
+"defect=BUGDB00034429").
+
+For the read case the rest of the keys are the names of the fields to retrieve
+with values that are undef'ed. For read/write, the rest of hash contains name
+value pairs of fields to set and their values.
+
+Execute returns a status and a hash of name value pairs for the read case and an
+array of lines for any error messages for the read/write case.
+
+=head1 ROUTINES
+
+The following methods are available:
+
+=cut
+
+package Clearquest::Server;
+
+use strict;
+use warnings;
+
+use Carp;
+use File::Basename;
+use FindBin;
+use IO::Socket;
+use Net::hostent;
+use POSIX qw(:sys_wait_h :signal_h);
+
+use DateUtils;
+use Display;
+use GetConfig;
+
+use Clearquest;
+
+# We cannot use parent here because CQPerl is used by the server. As such cqperl
+# doesn't have parent.pm!
+our @ISA = 'Clearquest';
+
+our $VERSION = '$Revision: 2.6 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+sub new (;%) {
+ my ($class, %parms) = @_;
+
+ my $self;
+
+ $parms{CQ_DATABASE} ||= $Clearquest::OPTS{CQ_DATABASE};
+ $parms{CQ_USERNAME} ||= $Clearquest::OPTS{CQ_USERNAME};
+ $parms{CQ_PASSWORD} ||= $Clearquest::OPTS{CQ_PASSWORD};
+ $parms{CQ_DBSET} ||= $Clearquest::OPTS{CQ_DBSET};
+ $parms{CQ_SERVER} ||= $Clearquest::OPTS{CQ_SERVER};
+ $parms{CQ_PORT} ||= $Clearquest::OPTS{CQ_PORT};
+
+ $parms{CQ_MULTITHREADED} = $Clearquest::OPTS{CQ_MULTITHREADED}
+ unless defined $parms{CQ_MULTITHREADED};
+
+ # The server always uses the standard Clearquest API
+ $parms{CQ_MODULE} = 'api';
+
+ # Set data members
+ $self->{username} = $parms{CQ_USERNAME};
+ $self->{password} = $parms{CQ_PASSWORD};
+ $self->{database} = $parms{CQ_DATABASE};
+ $self->{dbset} = $parms{CQ_DBSET};
+ $self->{server} = $parms{CQ_SERVER};
+ $self->{port} = $parms{CQ_PORT};
+ $self->{module} = $parms{CQ_MODULE};
+ $self->{multithreaded} = $parms{CQ_MULTITHREADED};
+
+ return bless $self, $class;
+} # new
+
+sub _tag ($) {
+ my ($self, $msg) = @_;
+
+ my $tag = YMDHMS;
+ $tag .= ' ';
+ $tag .= $self->{pid} ? '[' . abs ($self->{pid}) . '] ' : '';
+
+ return "$tag$msg";
+} # _tag
+
+sub _verbose ($) {
+ my ($self, $msg) = @_;
+
+ verbose $self->_tag ($msg);
+
+ return;
+} # _verbose
+
+sub _debug ($) {
+ my ($self, $msg) = @_;
+
+ debug $self->_tag ($msg);
+
+ return;
+} # _debug
+
+sub _log ($) {
+ my ($self, $msg) = @_;
+
+ display $self->_tag ($msg);
+
+ return;
+} # log
+
+sub _funeral () {
+ debug "Entered _funeral";
+
+ while (my $childpid = waitpid (-1, WNOHANG) > 0) {
+ my $status = $?;
+
+ if ($childpid != -1) {
+ local $SIG{CHLD} = \&_funeral;
+
+ my $msg = 'Child has died';
+ $msg .= $status ? " with status $status" : '';
+
+ verbose "[$childpid] $msg"
+ if $status;
+ } # if
+ } # while
+
+ return;
+} # _funeral
+
+sub _endServer () {
+ display "Clearquest::Server V$VERSION shutdown at " . localtime;
+
+ # Kill process group
+ kill 'TERM', -$$;
+
+ # Wait for all children to die
+ while (wait != -1) {
+ # do nothing
+ } # while
+
+ # Now that we are alone, we can simply exit
+ exit;
+} # _endServer
+
+sub _restartServer () {
+ # Not sure what to do on a restart server
+ display 'Entered _restartServer';
+
+ return;
+} # _restartServer
+
+sub _printStatus ($) {
+ my ($self, $client) = @_;
+
+ my $status = $self->{clearquest}->error;
+
+ $status ||= 0;
+
+ $self->_debug ("Printing status: " . __PACKAGE__ . " Status: $status");
+
+ print $client __PACKAGE__ . " Status: $status\n";
+
+ $self->_debug ("After print");
+
+ return;
+} # printStatus
+
+sub _connectToClearquest ($$$$) {
+ my ($self, $database, $username, $password, $dbset) = @_;
+
+ my %parms;
+
+ $parms{CQ_DATABASE} = $database;
+ $parms{CQ_USERNAME} = $username;
+ $parms{CQ_PASSWORD} = $password;
+ $parms{CQ_DBSET} = $dbset;
+
+ # The server always uses the standard Clearquest API
+ $parms{CQ_MODULE} = 'api';
+
+ # Connect to Clearquest database
+ $self->{clearquest} = Clearquest->new (%parms);
+
+ $self->_verbose ("Connecting to "
+ . "$parms{CQ_USERNAME}\@$parms{CQ_DATABASE}/$parms{CQ_DBSET}"
+ . " for $self->{clientname}");
+
+ $self->{loggedin} = $self->{clearquest}->connect;
+
+ return $self->{loggedin};
+} # _connectToClearquest
+
+sub _processCommand ($$@) {
+ my ($self, $client, $call, @parms) = @_;
+
+ $self->_debug ("Client wishes to execute $call");
+
+ if ($call eq 'end') {
+ $self->_verbose ("Serviced requests from $self->{clientname}");
+
+ close $client;
+
+ $self->disconnectFromClient;
+
+ return 1;
+ } elsif ($call eq 'open') {
+ debug "connectToClearquest";
+ unless ($self->_connectToClearquest (@parms)) {
+ debug "Error: " . $self->{clearquest}->errmsg;
+ print $client $self->{clearquest}->errmsg . "\n";
+ } else {
+ debug "Success!";
+ print $client 'Connected to '
+ . $self->username () . '@'
+ . $self->database () . '/'
+ . $self->dbset () . "\n";
+ } # if
+
+ debug "Calling _printStatus";
+ $self->_printStatus ($client);
+ } elsif ($call eq 'get') {
+ my %record = $self->{clearquest}->get (@parms);
+
+ unless ($self->{clearquest}->error) {
+ foreach my $field (keys %record) {
+ # TODO: Need to handle field types better...
+ if (ref $record{$field} eq 'ARRAY') {
+ foreach (@{$record{$field}}) {
+ # Change \n's to
+ s/\r\n/ /gm;
+
+ print $client "$field\@\@$_\n";
+ } # foreach
+ } else {
+ # Change \n's to
+ $record{$field} =~ s/\r\n/ /gm;
+
+ print $client "$field\@\@$record{$field}\n";
+ } # if
+ } # foreach
+ } else {
+ print $client $self->{clearquest}->errmsg . "\n";
+ } # unless
+
+ $self->_printStatus ($client);
+ } elsif ($call eq 'find') {
+ my ($result, $nbrRecs) = $self->{clearquest}->find (@parms);
+
+ if ($self->{clearquest}->error != 0) {
+ print $client $self->{clearquest}->errmsg . "\n";
+ } else {
+ # Store away $result so we can use it later
+ $self->{result} = $result;
+
+ print $client "$result\n$nbrRecs\n";
+ } # if
+
+ $self->_printStatus ($client);
+ } elsif ($call eq 'getnext') {
+ my %record = $self->{clearquest}->getNext ($self->{result});
+
+ unless ($self->{clearquest}->error) {
+ foreach my $field (keys %record) {
+ # TODO: Need to handle field types better...
+ if (ref $record{$field} eq 'ARRAY') {
+ foreach (@{$record{$field}}) {
+ # Change \n's to
+ s/\r\n/ /gm;
+
+ print $client "$field\@\@$_\n";
+ } # foreach
+ } else {
+ # Change \n's to
+ $record{$field} =~ s/\r\n/ /gm;
+
+ print $client "$field\@\@$record{$field}\n";
+ } # if
+ } # foreach
+ } else {
+ print $client $self->{clearquest}->errmsg . "\n";
+ } # unless
+
+ $self->_printStatus ($client);
+ } elsif ($call eq 'getdynamiclist') {
+ # TODO Better error handling/testing
+ my @entry = $self->{clearquest}->getDynamicList (@parms);
+
+ print $client "$_\n" foreach @entry;
+
+ $self->_printStatus ($client);
+ } elsif ($call eq 'dbsets') {
+ # TODO Better error handling/testing
+ print $client "$_\n" foreach ($self->{clearquest}->DBSets);
+
+ $self->_printStatus ($client);
+ } elsif ($call eq 'key') {
+ # TODO Better error handling/testing
+ print $client $self->{clearquest}->key (@parms) . "\n";
+
+ $self->_printStatus ($client);
+ } elsif ($call eq 'modify' or $call eq 'modifyDBID') {
+ my $table = shift @parms;
+ my $key = shift @parms;
+ my $action = shift @parms;
+
+ # Need to turn off strict for eval here...
+ my ($values, @ordering);
+ no strict;
+ eval $parms[0];
+
+ $values = $VAR1;
+ use strict;
+
+ @ordering = @{$parms[1]} if ref $parms[1] eq 'ARRAY';
+
+ my $errmsg;
+
+ if ($call eq 'modify') {
+ $errmsg = $self->{clearquest}->modify ($table, $key, $action, $values, @ordering);
+ } elsif ($call eq 'modifyDBID') {
+ $errmsg = $self->{clearquest}->modifyDBID ($table, $key, $action, $values, @ordering);
+ } # if
+
+ print $client "$errmsg\n" if $errmsg ne '';
+
+ $self->_printStatus ($client);
+ } elsif ($call eq 'add') {
+ my $dbid = $self->{clearquest}->add (@parms);
+
+ if ($self->{clearquest}->error) {
+ print $client 'ERROR: ' . $self->{clearquest}->errmsg () . "\n";
+ } # if
+
+ $self->_printStatus ($client);
+ } elsif ($call eq 'delete') {
+ $self->{clearquest}->delete (@parms);
+
+ if ($self->{clearquest}->error) {
+ print $client 'ERROR: ' . $self->{clearquest}->errmsg () . "\n";
+ } # if
+
+ $self->_printStatus ($client);
+ } else {
+ $self->{clearquest}->{errnbr} = -1;
+ $self->{clearquest}->{errmsg} = "Unknown call $call";
+
+ print $client $self->{clearquest}->errmsg . "\n";
+
+ $self->_printStatus ($client);
+ } # if
+
+ return;
+} # _processCommand
+
+sub _serviceClient ($) {
+ my ($self, $client) = @_;
+
+ $self->_verbose ("Servicing requests from $self->{clientname}");
+
+ # Set autoflush for client
+ $client->autoflush if $client;
+
+ my $line;
+
+ $self->_debug ("Reading request from client");
+
+ while ($line = <$client>) {
+ $self->_debug ("Request read: $line");
+
+ if ($line) {
+ chomp $line; chop $line if $line =~ /\r$/;
+ } else {
+ $self->_verbose ("Host $self->{clientname} went away!");
+
+ close $client;
+
+ return;
+ } # if
+
+ if ($line =~ /^shutdown/i) {
+ if ($self->{server}) {
+ $self->_verbose ("$self->{clientname} requested to shutdown the server");
+
+ print $client __PACKAGE__ . " Status: 0\n";
+ } # if
+
+ # TODO: This is not working because getppid is not implemented on Windows!
+ #kill HUP => getppid;
+
+ exit 1;
+ } # if
+
+ # Parse command line
+ my ($call, @parms);
+
+ if ($line =~ /^\s*(\S+)\s+(.*)/) {
+ $call = lc $1;
+
+ no strict;
+ eval $2;
+
+ @parms = @$VAR1;
+ use strict;
+
+ my $i = 0;
+
+ foreach (@parms) {
+ if (/^\$VAR1/) {
+ no strict;
+ eval;
+
+ $parms[$i++] = $VAR1;
+ use strict;
+ } else {
+ $i++;
+ } # if
+ } # foreach
+ } elsif ($line =~ /^\s*(\S+)/) {
+ $call = lc $1;
+ @parms = ();
+ } else {
+ my $errmsg = "Garbled command line: '$line'";
+
+ if ($self->{clearquest}) {
+ $self->{clearquest}->{errnbr} = -1;
+ $self->{clearquest}->{errmsg} = $errmsg;
+
+ print $client $self->{clearquest}->errmsg . "\n";
+ } else {
+ print "$errmsg\n";
+ } # if
+
+ $self->_printStatus ($client);
+
+ return;
+ } # if
+
+ $self->_debug ("Processing command $call @parms");
+
+ last if $self->_processCommand ($client, $call, @parms);
+ } # while
+
+ return;
+} # _serviceClient
+
+sub multithreaded (;$) {
+ my ($self, $newValue) = @_;
+
+ my $oldValue = $self->{multithreaded};
+
+ $self->{multithreaded} = $newValue if $newValue;
+
+ return $oldValue
+} # multithreaded
+
+sub disconnectFromClient () {
+ my ($self) = @_;
+
+ # Destroy Clearquest object so we disconnect from Clearquest.
+ undef $self->{clearquest};
+
+ $self->_verbose ("Disconnected from client $self->{clientname}")
+ if $self->{clientname};
+
+ undef $self->{clientname};
+
+ return;
+} # disconnectFromClient
+
+sub DESTROY () {
+ my ($self) = @_;
+
+ $self->disconnectFromClient;
+
+ if ($self->{socket}) {
+ close $self->{socket};
+
+ undef $self->{socket};
+ } # if
+} # DESTROY
+
+sub startServer () {
+ my ($self) = @_;
+
+ # Create new socket to communicate to clients with
+ $self->{socket} = IO::Socket::INET->new (
+ Proto => 'tcp',
+ LocalPort => $self->{port},
+ Listen => SOMAXCONN,
+ ReuseAddr => 1,
+ );
+
+ error "Could not create socket - $!", 1
+ unless $self->{socket};
+
+ # Announce ourselves
+ $self->_log (__PACKAGE__ . " V$VERSION accepting clients at " . localtime);
+
+ $SIG{HUP} = \&_endServer;
+
+ # Now wait for an incoming request
+ my $client;
+
+ LOOP: while () {
+ $client = $self->{socket}->accept;
+
+ if ($? == -1) {
+ if ($!{EINTR}) {
+ next;
+ } else {
+ error "Accept called failed (Error: $?) - $!", 1;
+ } # if
+ } # if
+
+ my $hostinfo = gethostbyaddr $client->peeraddr;
+
+ $self->{clientname} = $hostinfo ? $hostinfo->name : $client->peerhost;
+
+ $self->_verbose ("$self->{clientname} is requesting service");
+
+ if ($self->multithreaded) {
+ $self->{pid} = $$;
+
+ my $childpid;
+
+ $self->_debug ("Spawning child to handle request");
+
+ error "Can't fork: $!"
+ unless defined ($childpid = fork);
+
+ if ($childpid) {
+ $self->{pid} = $$;
+
+ # Signal handling sucks under Windows. For example, we cannot catch
+ # SIGCHLD when using the ActiveState based cqperl when running on
+ # Windows. If there will be a zombie apocalypse it will start on
+ # Windows! ;-)
+ unless ($^O =~ /win/i) {
+ my $sigset = POSIX::SigSet->new (&POSIX::SIGCHLD);
+ my $sigaction = POSIX::SigAction->new (\&_funeral, $sigset, &POSIX::SA_RESTART);
+ } # unless
+
+ $self->_debug ("Parent produced child [$childpid]");
+ } else {
+ # In child process - ServiceClient
+ $self->{pid} = $$;
+
+ # Now exec the caller but set STDIN to be the socket. Also pass
+ # -serviceClient to the caller which will need to handle that and call
+ # _serviceClient.
+ $self->_debug ("Client: $client");
+ open STDIN, '+<&', $client
+ or croak "Unable to dup client";
+
+ my $cmd = "cqperl \"$FindBin::Bin/$FindBin::Script -serviceClient=$self->{clientname} -verbose -debug";
+
+ $self->_debug ("Execing: $cmd");
+
+ exec 'cqperl', "\"$FindBin::Bin/$FindBin::Script\"", "-serviceClient=$self->{clientname}", '-verbose', '-debug'
+ or croak "Unable to exec $cmd";
+ } # if
+ } else {
+ $self->_serviceClient ($client);
+ } # if
+ } # while
+
+ # On Windows we can't catch SIGCHLD so we need to loop around. Ugly!
+ goto LOOP if $^O =~ /win/i;
+} # startServer
+
+1;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<Carp>
+
+L<File::Basename|File::Basename>
+
+L<FindBin>
+
+L<IO::Socket|IO::Socket>
+
+L<Net::hostent|Net::hostent>
+
+L<POSIX>
+
+=head2 ClearSCM Perl Modules
+
+=begin man
+
+ DateUtils
+ Display
+ GetConfig
+
+=end man
+
+=begin html
+
+<blockquote>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/DateUtils.pm">DateUtils</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
+<a href="http://clearscm.com/php/cvs_man.php?file=lib/GetConfig.pm">GetConf</a><br>
+</blockquote>
+
+=end html
+
+=head1 SEE ALSO
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this module.
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2011, ClearSCM, Inc. All rights reserved.
+
+=cut
--- /dev/null
+=pod
+
+=head1 NAME $RCSfile: CmdLine.pm,v $
+
+Library to implement generic command line interface
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.13 $
+
+=item Created
+
+Fri May 13 15:23:37 PDT 2011
+
+=item Modified
+
+$Date: 2011/12/23 01:02:49 $
+
+=back
+
+=head1 SYNOPSIS
+
+Provides an interface to a command line utilizing Term::ReadLine and
+Term::ReadLine::Gnu. Note, the latter is not part of Perl core and
+must be downloaded from CPAN. Without Term::ReadLine::Gnu a lot of
+functionality doesn't work.
+
+CmdLine uses a hash to describe what your valid commands are along
+with help and longer help, i.e. description strings. If you do not
+define your commands then no command name completion nor help will be
+available.
+
+ use FindBin;
+ use CmdLine;
+
+ my %cmds = (
+ list => (
+ help => 'help [<cmd>]'
+ description => 'This is a longer description
+of the list command',
+ ),
+ execute => (
+ help => 'execute <cmd>',
+ description => 'Longer description of the execute command',
+ ),
+ );
+
+ # Create a new cmdline:
+ my $cmdline = CmdLine->new ($FindBin::Script, %cmds);
+
+ while (my $cmd = $cmdline->get) {
+ ...
+ } # while
+
+=head1 DESCRIPTION
+
+This module implements a command line stack using Term::ReadLine and
+Term::ReadLine::Gnu. If Term::ReadLine::Gnu is not installed then many
+of the functions do not work. Command completion if commands are
+defined with a hash as shown above.
+
+=head1 DEFAULT COMMANDS
+
+The for a list of the builtin commands see %builtin_cmds below
+
+Additionally !<n> will re-exeucte a comand from history and !<cmd>
+will execute <cmd as a shell command.
+
+=head1 ROUTINES
+
+The following routines are exported:
+
+=cut
+
+package CmdLine;
+
+use strict;
+use warnings;
+
+use base 'Exporter';
+
+use Carp;
+use Config;
+use Display;
+use Utils;
+
+use Term::ReadLine;
+use Term::ANSIColor qw (color);
+
+# Package globals
+my $_pos = 0;
+my $_haveGnu;
+
+my (%_cmds, $_cmdline, $_attribs);
+
+BEGIN {
+ # See if we can load Term::ReadLine::Gnu
+ eval { require Term::ReadLine::Gnu };
+
+ if ($@) {
+ warning "Unable to load Term::ReadLine::Gnu\nCmdLine functionality will be limited!";
+ $_haveGnu = 0;
+ } else {
+ $_haveGnu = 1;
+ } # if
+} # BEGIN
+
+# Share %opts
+our %opts;
+
+my %builtin_cmds = (
+ history => {
+ help => 'history [<start> <end>]',
+ description => 'Displays cmd history. You can specify where to <start> and where to <end>.
+Default is to list only the last screen full lines of history
+(as denoted by $LINES).'
+ },
+
+ help => {
+ help => 'help [<cmd>]',
+ description => 'Displays help.',
+ },
+
+ savehist => {
+ help => 'savehist <file> [<start> <end>]',
+ description => 'Saves a section of the history to a file. You can specify where to <start>
+and where to <end>. Default is to save all of the history to
+the specified file.',
+ },
+
+ get => {
+ help => 'get <var>',
+ description => 'Gets a variable.',
+ },
+
+ set => {
+ help => 'set <var>=<expression>',
+ description => 'Sets a variable. Note that expression can be any valid expression.',
+ },
+
+ vars => {
+ help => 'vars',
+ description => 'Displays all known variables.',
+ },
+
+ source => {
+ help => 'source <file>',
+ description => 'Run commands from a file.',
+ },
+
+ color => {
+ help => 'color [<on|off>]',
+ description => 'Turn on|off color. With no options displays status of color.',
+ },
+
+ trace => {
+ help => 'trace [<on|off>]',
+ description => 'Turn on|off tracing. With no options displays status of trace.',
+ },
+);
+
+sub _cmdCompletion ($$) {
+ my ($text, $state) = @_;
+
+ return unless %_cmds;
+
+ $_pos = 0 unless $state;
+
+ my @cmds = keys %_cmds;
+
+ for (; $_pos < @cmds;) {
+ return $cmds[$_pos - 1]
+ if $cmds[$_pos++] =~ /^$text/i;
+ } # for
+
+ return;
+}# _cmdCompletion
+
+sub _complete ($$$$) {
+ my ($text, $line, $start, $end) = @_;
+
+ return $_cmdline->completion_matches ($text, \&CmdLine::_cmdCompletion);
+} # _complete
+
+sub _gethelp () {
+ my ($self) = @_;
+
+ return unless %_cmds;
+
+ my $line = $_cmdline->{line_buffer};
+
+ # Trim
+ $line =~ s/^\s+//;
+ $line =~ s/\s+$//;
+
+ display '';
+
+ # Sometimes we are called by ReadLine's callback and can't pass $self
+ if (ref $self eq 'CmdLine') {
+ $self->help ($line);
+ } else {
+ $CmdLine::cmdline->help ($line);
+ } # if
+
+ $_cmdline->on_new_line;
+} # _gethelp
+
+sub _interpolate ($) {
+ my ($self, $str) = @_;
+
+ # Skip interpolation for the perl command (Note this is raid specific)
+ return $str
+ if $str =~ /^\s*perl\s*/i;
+
+ while ($str =~ /\$/) {
+ if ($str =~ /\$(\w+)/) {
+ my $varname = $1;
+
+ if (defined $self->{vars}{$varname}) {
+ if ($self->{vars}{$varname} =~ / /) {
+ $str =~ s/\$$varname/\'$self->{vars}{$varname}\'/;
+ } else {
+ $str =~ s/\$$varname/$self->{vars}{$varname}/;
+ } # if
+ } else {
+ $str =~ s/\$$varname//;
+ } # if
+ } # if
+ } # while
+
+ return $str;
+} # _interpolate
+
+sub _builtinCmds ($) {
+ my ($self, $line) = @_;
+
+ unless (defined $line) {
+ display '';
+ return 'exit';
+ } # unless
+
+ my ($cmd, $result);
+
+ # Short circut "psuedo" commands of !<n> and !<shellcmd>
+ if ($line =~ /^\s*!\s*(\d+)/) {
+ $line = $self->history ('redo', $1);
+ } elsif ($line =~ /^\s*!\s*(\S+)\s*(.*)/) {
+ if ($2) {
+ system "$1 $2";
+ } else {
+ system $1;
+ } # if
+
+ #$_cmdline->remove_history ($_cmdline->where_history);
+
+ return;
+ } # if
+
+ if ($line =~ /^\s*(\S+)/) {
+ $cmd = $1;
+ } # if
+
+ return
+ unless $cmd;
+
+ my @parms;
+
+ # Search for matches of partial commands
+ my $foundCmd;
+
+ foreach (keys %builtin_cmds) {
+ if ($_ eq $cmd) {
+ # Exact match - honor it
+ $foundCmd = $cmd;
+ last;
+ } elsif (/^$cmd/) {
+ # Command matched partially
+ unless ($foundCmd) {
+ # Found first instance of a match
+ $foundCmd = $_;
+ } else {
+ # Found second instance of a match - $cmd is not unique
+ undef $foundCmd;
+ last;
+ } # unless
+ } # if
+ } # foreach
+
+ # If we found a command, substitute it into line
+ if ($foundCmd) {
+ $line =~ s/^\s*$cmd\s*/$foundCmd /;
+ $cmd = $foundCmd;
+ } # if
+
+ if ($builtin_cmds{$cmd}) {
+ if ($line =~ /^\s*help\s*(.*)/i) {
+ if ($1 =~ /(.+)$/) {
+ $self->help ($1);
+ } else {
+ $self->help;
+ } # if
+ } elsif ($line =~ /^\s*history\s*(.*)/i) {
+ if ($1 =~ /(\d+)\s+(\d+)\s*$/) {
+ $self->history ('list', $1, $2);
+ } elsif ($1 =~ /^\s*$/) {
+ $self->history ('list');
+ } else {
+ error "Invalid usage";
+ $self->help ('history');
+ } # if
+ } elsif ($line =~ /^\s*savehist\s*(.*)/i) {
+ if ($1 =~ /(\S+)\s+(\d+)\s+(\d+)\s*$/) {
+ $self->history ('save', $1, $2, $3);
+ } else {
+ error 'Invalid usage';
+ $self->help ('savehist');
+ } # if
+ } elsif ($line =~ /^\s*get\s*(.*)/i) {
+ if ($1 =~ (/^\$*(\S+)\s*$/)) {
+ my $value = $self->_get ($1);
+
+ if ($value) {
+ display "$1 = $value";
+ } else {
+ error "$1 is not set";
+ } # if
+ } else {
+ error 'Invalid usage';
+ $self->help ('get');
+ } # if
+ } elsif ($line =~ /^\s*set\s*(.*)/i) {
+ if ($1 =~ /^\$*(\S+)\s*=\s*(.*)/) {
+ $self->_set ($1, $2)
+ } else {
+ error 'Invalid usage';
+ $self->help ('set');
+ } # if
+ } elsif ($line =~ /^\s*source\s+(\S+)/i) {
+ $result = $self->source ($1);
+ } elsif ($line =~ /^\s*vars\s*/) {
+ $self->vars ($line);
+ } elsif ($line =~ /^\s*color\s*(.*)/i) {
+ if ($1 =~ /(1|on)/i) {
+ $opts{color} = 1;
+ delete $ENV{ANSI_COLORS_DISABLED}
+ if $ENV{ANSI_COLORS_DISABLED};
+ } elsif ($1 =~ /(0|off)/i) {
+ $opts{trace} = 0;
+ $ENV{ANSI_COLORS_DISABLED} = 1;
+ } elsif ($1 =~ /\s*$/) {
+ if ($ENV{ANSI_COLORS_DISABLED}) {
+ display 'Color is currently off';
+ } else {
+ display 'Color is currently on';
+ } # if
+ } else {
+ error 'Invalid usage';
+ $self->help ('color');
+ } # if
+ } elsif ($line =~ /^\s*trace\s*(.*)/i) {
+ if ($1 =~ /(1|on)/i) {
+ $opts{trace} = 1;
+ } elsif ($1 =~ /(0|off)/i) {
+ $opts{trace} = 0;
+ } elsif ($1 =~ /\s*$/) {
+ if ($opts{trace}) {
+ display 'Trace is currently on';
+ } else {
+ display 'Trace is currently off';
+ } # if
+ } else {
+ error 'Invalid usage';
+ $self->help ('trace');
+ } # if
+ } # if
+ } # if
+
+ return ($cmd, $line, $result);
+} # _builtinCmds
+
+sub _interrupt () {
+ # Announce that we have hit an interrupt
+ print color ('yellow') . "<Control-C>\n" . color ('reset');
+
+ # Free up all of the line state info
+ $_cmdline->free_line_state;
+
+ # Allow readline to clean up
+ $_cmdline->cleanup_after_signal;
+
+ # Redisplay prompt on a new line
+ $_cmdline->on_new_line;
+ $_cmdline->{line_buffer} = '';
+ $_cmdline->redisplay;
+
+ return;
+} # _interrupt
+
+sub _displayMatches ($$$) {
+ my ($matches, $numMatches, $maxLength) = @_;
+
+ # Work on a copy... (Otherwise we were getting "Attempt to free unreferenced
+ # scalar" internal errors from perl)
+ my @Matches;
+
+ push @Matches, $_ foreach (@$matches);
+
+ my $match = shift @Matches;
+
+ if ($match =~/^\s*(.*) /) {
+ $match = $1;
+ } elsif ($match =~ /^\s*(\S+)$/) {
+ $match = '';
+ } # if
+
+ my %newMatches;
+
+ foreach (@Matches) {
+ # Get next word
+ s/^$match//;
+
+ if (/(\w+)/) {
+ $newMatches{$1} = $1;
+ } # if
+ } # foreach
+
+ my @newMatches = sort keys %newMatches;
+
+ unshift @newMatches, $match;
+
+ $_cmdline->display_match_list (\@newMatches);
+ $_cmdline->on_new_line;
+ $_cmdline->redisplay;
+
+ return;
+} # _displayMatches
+
+sub new (;$$%) {
+ my ($class, $histfile, $eval, %cmds) = @_;
+
+=pod
+
+=head2 new ()
+
+Construct a new CmdLine object. Note there is already a default
+CmdLine object created named $cmdline. You should use that unless you
+have good reason to instantiate another CmdLine object.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $histfile
+
+Set to a file name where to write the history file. If not defined no
+history is kept.
+
+=item %cmds
+
+A hash describing the valid commands and their help/description
+strings.
+
+ my %cmds = (
+ 'list' => {
+ help => 'List all known commands',
+ description => 'This is a longer description
+ of the list command',
+ },
+ 'help' => {
+ help => 'This is a help command',
+ description => 'help <cmd>
+ Longer description of help',
+ },
+ );
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item CmdLine object
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my $self = bless {
+ histfile => $histfile,
+ }, $class;
+
+ my $me = get_me;
+
+ $histfile ||= ".${me}_hist";
+
+ error "Creating bogus .${me}_hist file!"
+ if $me eq '-';
+
+ unless (-f $histfile) {
+ open my $hist, '>', $histfile
+ or error "Unable to open $histfile for writing - $!", 1;
+
+ close $hist;
+ } # unless
+
+ # Instantiate a commandline
+ $_cmdline = Term::ReadLine->new ($me);
+
+ # Store the function pointer of what to call when sourcing a file or
+ # evaluating an expression.
+ if ($eval) {
+ if (ref $eval eq 'CODE') {
+ $self->{eval} = $eval;
+ } else {
+ error "Invalid function pointer\nUsage: CmdLine->new ($histfile, $eval, %cmds)", 1;
+ } # if
+ } # if
+
+ # Default prompt is "$me:"
+ $self->{prompt} = "$me:";
+
+ # Set commands
+ $self->set_cmds (%cmds);
+
+ # Set some ornamentation
+ $_cmdline->ornaments ('s,e,u,') unless $Config{cppflags} =~ /win32/i;
+
+ # Read in history
+ $self->set_histfile ($histfile);
+
+ # Generator function for completion matches
+ $_attribs = $_cmdline->Attribs;
+
+ $_attribs->{attempted_completion_function} = \&CmdLine::_complete;
+ $_attribs->{completion_display_matches_hook} = \&CmdLine::_displayMatches;
+ $_attribs->{completer_word_break_characters} =~ s/ //
+ if $_attribs->{completer_word_break_characters};
+
+ # The following functionality requires Term::ReadLine::Gnu
+ if ($_haveGnu) {
+ # Bind a key to display completion
+ $_cmdline->add_defun ('help-on-command', \&CmdLine::_gethelp, ord ("\cl"));
+
+ # Save a handy copy of RL_PROMPT_[START|END]_IGNORE
+ $self->{ignstart} = $_cmdline->RL_PROMPT_START_IGNORE;
+ $self->{ignstop} = $_cmdline->RL_PROMPT_END_IGNORE;
+ } # if
+
+ if ($Config{cppflags} =~ /win32/i) {
+ $opts{trace} = 0;
+ $ENV{ANSI_COLORS_DISABLED} = 1;
+ } # if
+
+ return $self;
+} # new
+
+sub get () {
+ my ($self) = @_;
+
+=pod
+
+=head2 get
+
+Retrieves a command line
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item None
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $cmds
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my ($cmd, $line, $result);
+
+ do {
+ # Substitute cmdnbr into prompt if we find a '\#'
+ my $prompt = $self->{prompt};
+
+ $prompt =~ s/\\\#/$self->{cmdnbr}/g;
+
+ use POSIX;
+
+ # Term::ReadLine::Gnu restarts whatever system call it is using, such that
+ # once we ctrl C, we don't get back to Perl until the user presses enter,
+ # finally whereupon we get our signal handler called. We use sigaction
+ # instead to use the old perl unsafe signal handling, but only in this read
+ # routine. Sure, sigaction poses race conditions, but you'd either be at a
+ # prompt or executing whatever command your prompt prompted for. The user
+ # has said "Abort that!" with his ctrl-C and we're attempting to honor that.
+
+ # Damn Windows can't do any of this
+ my $oldaction;
+
+ if ($Config{cppflags} !~ /win32/i) {
+ my $sigset = POSIX::SigSet->new;
+ my $sigaction = POSIX::SigAction->new (\&_interrupt, $sigset, 0);
+
+ $oldaction = POSIX::SigAction->new;
+
+ # Set up our unsafe signal handler
+ POSIX::sigaction (&POSIX::SIGINT, $sigaction, $oldaction);
+ } # if
+
+ $line = $_cmdline->readline ($prompt);
+
+ # Restore the old signal handler
+ if ($Config{cppflags} !~ /win32/i) {
+ POSIX::sigaction (&POSIX::SIGINT, $oldaction);
+ } # if
+
+ $line = $self->_interpolate ($line)
+ if $line;
+
+ $self->{cmdnbr}++
+ unless $self->{sourcing};
+
+ ($cmd, $line, $result) = $self->_builtinCmds ($line);
+
+ $line = ''
+ unless $cmd;
+ } while ($cmd and $builtin_cmds{$cmd});
+
+ return ($line, $result);
+} # get
+
+sub set_cmds (%) {
+ my ($self, %cmds) = @_;
+
+=pod
+
+=head2 set_cmds
+
+Sets the cmds
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item %cmds
+
+New commands to use
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Nothing
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ %_cmds = %cmds;
+
+ # Add in builtins
+ foreach (keys %builtin_cmds) {
+ $_cmds{$_}{help} = $builtin_cmds{$_}{help};
+ $_cmds{$_}{description} = $builtin_cmds{$_}{description};
+ } # foreach
+
+ return;
+} # set_cmds
+
+sub set_prompt ($) {
+ my ($self, $prompt) = @_;
+
+=pod
+
+=head2 set_prompt
+
+Sets the prompt
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $new_prompt
+
+New commands to use
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $old_prompt
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my $return = $self->{prompt};
+
+ $self->{prompt} = $prompt;
+
+ return $return;
+} # set_prompt
+
+sub set_histfile ($) {
+ my ($self, $histfile) = @_;
+
+=pod
+
+=head2 set_histfile
+
+Sets the histfile
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $histfile
+
+New commands to use
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Nothing
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ if ($histfile and -f $histfile) {
+ $self->{histfile} = $histfile;
+
+ if ($_haveGnu) {
+ # Clear old history (if any);
+ $_cmdline->clear_history;
+
+ # Now read histfile
+ $_cmdline->ReadHistory ($histfile);
+ } # if
+
+ # Determine the number of lines in the history file
+ open my $hist, '<', $histfile;
+
+ # Set cmdnbr
+ for (<$hist>) {}
+ $self->{cmdnbr} = $. + 1;
+
+ close $hist;
+ } # if
+
+ return;
+} # set_histfile
+
+sub set_eval (;\&) {
+ my ($self, $eval) = @_;
+
+=pod
+
+=head2 set_eval
+
+Sets the eval function pointer
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item [\&function]
+
+Function to set eval to. This function will be called with the command
+line as the only paramter and it should return a result.
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item \&old_eval
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my $returnEval = $self->{eval};
+
+ $self->{eval} = $eval;
+
+ return $returnEval;
+} # set_eval
+
+sub help (;$) {
+ my ($self, $cmd) = @_;
+
+=pod
+
+=head2 help [<cmd>]
+
+Displays help
+
+Note that the user does not need to explicitly call help - CmdLine's
+get method will already sense that the builtin help command was
+invoked and handle it. This method is provided if the caller wishes to
+call this internally for some reason.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $cmd
+
+Optional command help
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Nothing
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my @help;
+
+ $cmd ||= '';
+ $cmd =~ s/^\s+//;
+ $cmd =~ s/\s+$//;
+
+ if ($cmd =~ /^\s*(.+)/) {
+ my ($searchStr, $helpFound);
+
+ $searchStr = $1;
+
+ foreach (sort keys %_cmds) {
+ if (/$searchStr/i) {
+ $helpFound = 1;
+
+ my $cmdcolor = $builtin_cmds{$_} ? color ('cyan') : color ('magenta');
+ my $boldOn = $builtin_cmds{$_} ? color ('white on_cyan') : color ('white on_magenta');
+ my $boldOff = color ('reset') . $cmdcolor;
+
+ my $cmd = "$cmdcolor$_";
+ $cmd =~ s/($searchStr)/$boldOn$1$boldOff/g;
+ $cmd .= " $_cmds{$_}{parms}" if $_cmds{$_}{parms};
+ $cmd .= color ('reset');
+ $cmd .= " - $_cmds{$_}{help}" if $_cmds{$_}{help};
+
+ push @help, $cmd;
+
+ if ($_cmds{$_}{description}) {
+ push @help, " $_"
+ foreach (split /\n/, $_cmds{$_}{description});
+ } # if
+ } # if
+ } # foreach
+
+ unless ($helpFound) {
+ display "I don't know about $cmd";
+
+ return;
+ } # if
+ } else {
+ foreach (sort keys %_cmds) {
+ my $cmdcolor = $builtin_cmds{$_} ? color ('cyan') : color ('magenta');
+
+ my $cmd = "$cmdcolor$_";
+ $cmd .= " $_cmds{$_}{parms}" if $_cmds{$_}{parms};
+ $cmd .= color ('reset');
+ $cmd .= " - $_cmds{$_}{help}" if $_cmds{$_}{help};
+
+ push @help, $cmd;
+
+ if ($_cmds{$_}{description}) {
+ push @help, " $_"
+ foreach (split /\n/, $_cmds{$_}{description});
+ } # if
+ } # foreach
+ } # if
+
+ $self->handleOutput ($cmd, @help);
+
+ return;
+} # help
+
+sub history (;$) {
+ my ($self, $action) = @_;
+
+=pod
+
+=head2 history <action> [<file>] [<start> <end>]
+
+This method lists, saves or executes (redo) a command from the history
+stack. <action> can be one of 'list', 'save' or 'redo'. If listing
+history one can specify the optional <start> and <end> parameters. If
+saving then <file> must be specified and optionally <start> and
+<end>. If redoing a command then only <start> or the command number
+should be specified.
+
+Note that the user does not need to explicitly call history -
+CmdLine's get method will already sense that the builtin history
+command was invoked and handle it. This method is provided if the
+caller wishes to call this internally for some reason.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $action
+
+One of 'list', 'save' or 'redo'
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Nothing
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ if ($Config{cppflags} =~ /win32/i) {
+ warning 'The history command does not work on Windows (sorry)';
+
+ return;
+ } # if
+
+ my ($file, $start, $end);
+
+ if ($action eq 'list') {
+ $start = $_[2];
+ $end = $_[3];
+ } elsif ($action eq 'save') {
+ $file = $_[2];
+ $start = $_[3];
+ $end = $_[4];
+ } elsif ($action eq 'redo') {
+ $_cmdline->remove_history ($_cmdline->where_history);
+
+ my $nbr = $_[2];
+ my $line = $_cmdline->history_get ($nbr);
+
+ $_cmdline->add_history ($line);
+ display $line;
+
+ my ($cmd, $result) = $self->_builtinCmds ($line);
+
+ if ($builtin_cmds{$cmd}) {
+ return;
+ } else {
+ return $line;
+ } # if
+ } else {
+ error "Unknown action $action in history";
+ return;
+ } # if
+
+ my $current = $_cmdline->where_history;
+
+ my $lines = ($ENV{LINES} ? $ENV{LINES} : 24) - 2;
+
+ $start = $current - $lines
+ unless defined $start;
+ $start = 1
+ if $start < 1;
+ $end = $current
+ unless defined $end;
+ $end = 1
+ if $end < 1;
+
+ if ($start > $end) {
+ error "Start ($start) is > end ($end)";
+ help ('history');
+ } else {
+ my $savefile;
+
+ if ($action eq 'save') {
+ unless ($file) {
+ error "Usage: savehist <file> [<start> <end>]";
+ return;
+ } # unless
+
+ if (-f $file) {
+ display_nolf "Overwrite $file (yN)? ";
+
+ my $response = <STDIN>;
+
+ unless ($response =~ /(y|yes)/i) {
+ display "Not overwritten";
+ return;
+ } # unless
+ } # if
+
+ my $success = open $savefile, '>', $file;
+
+ unless ($success) {
+ error "Unable to open history file $file - $!";
+ return;
+ } # unless
+ } # if
+
+ for (my $pos = $start; $pos <= $end; $pos++) {
+ my $histline = $_cmdline->history_get ($pos);
+
+ last unless $histline;
+
+ if ($action eq 'list') {
+ display "$pos) $histline";
+ } else {
+ print $savefile "$histline\n";
+ } # if
+ } # for
+
+ close $savefile
+ if $action eq 'save';
+ } # if
+
+ return;
+} # history
+
+sub _get ($$) {
+ my ($self, $name) = @_;
+
+=pod
+
+=head2 _get ($name)
+
+This method gets a variable to a value stored in the CmdLine
+object.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $name
+
+Name of the variable
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $value
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{vars}{$name}
+} # _get
+
+sub _set ($$) {
+ my ($self, $name, $value) = @_;
+
+=pod
+
+=head2 _set ($name, $value)
+
+This method sets a variable to a value stored in the CmdLine
+object. Note $value will be evaluated if eval is set.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $name
+
+Name of the variable
+
+=item $value
+
+Value of the variable
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $oldvalue
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my $returnValue = $self->{vars}{$name};
+
+ if (defined $value) {
+ $value = $self->_interpolate ($value);
+
+ # Do not call eval if we are setting result - otherwise we recurse
+ # infinitely.
+ unless ($name eq 'result') {
+ no strict;
+ $value = $self->{eval} ($value)
+ if $self->{eval};
+ use strict;
+ } # unless
+
+ $self->{vars}{$name} = $value;
+ } else {
+ delete $self->{vars}{$name};
+ } # if
+
+ return $returnValue;
+} # _set
+
+sub vars ($) {
+ my ($self, $cmd) = @_;
+
+=pod
+
+=head2 vars ($name)
+
+This method will print out all known variables
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Nothing
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my @output;
+
+ push @output, "$_ = $self->{vars}{$_}"
+ foreach (keys %{$self->{vars}});
+
+ $self->handleOutput ($cmd, @output);
+} # vars
+
+sub handleOutput ($@) {
+ my ($self, $line, @output) = @_;
+
+=pod
+
+=head2 handleOutput ($line, @output)
+
+This method will handle outputing the array @output. It also handles redirection
+(currently only output redirection) and piping
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $line
+
+The command line used to produce @output. This method parses out redirection
+(i.e. > and >>) and piping (|) from $cmd
+
+=item @output
+
+The output produced by the command to redirect or pipe. (Note this isn't true
+piping in that command must run first and produce all of @output before we are
+called. Need to look into how to use Perl's pipe command here).
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Nothing
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my ($outToFile, $pipeToCmd);
+
+ # Handle piping and redirection
+ if ($line =~ /(.*)\>{2}\s*(.*)/) {
+ $line = $1;
+ $outToFile = ">$2";
+ } elsif ($line =~ /(.*)\>{1}\s*(.*)/) {
+ $line = $1;
+ $outToFile = $2;
+ } elsif ($line =~ /(.*?)\|\s*(.*)/) {
+ $line = $1;
+ $pipeToCmd = $2;
+ } # if
+
+ # Store @output
+ $self->{output} = \@output;
+
+ if ($pipeToCmd) {
+ my $pipe;
+
+ local $SIG{PIPE} = 'IGNORE';
+
+ open $pipe, "|$pipeToCmd"
+ or undef $pipe;
+
+ # TODO: Not handling the output here. Need open2 and then recursively call
+ # handleOutput.
+ if ($pipe) {
+ print $pipe "$_\n"
+ foreach (@output);
+
+ close $pipe
+ or error "Unable to close pipe for $pipeToCmd - $!";
+ } else {
+ error "Unable to open pipe for $pipeToCmd - $!";
+ } # if
+ } else {
+ unless ($outToFile) {
+ PageOutput @output;
+ } else {
+ open my $output, ">$outToFile";
+
+ if ($output) {
+ print $output "$_\n"
+ foreach (@output);
+
+ close $output;
+
+ undef $outToFile;
+ } else {
+ error "Unable to open $outToFile for writing - $!"
+ } # if
+ } # unless
+ } # if
+
+ return;
+} # handleOutput
+
+sub source ($) {
+ my ($self, $file) = @_;
+
+=pod
+
+=head2 source <file>
+
+This method opens a file and sources it's content by executing each
+line. Note that the user must have set $self->{eval} to a function
+pointer. The function will be called with one parameter - the command
+line to execute. The function will return the result from the
+execution of the final command.
+
+Note that the user does not need to explicitly call source -
+CmdLine's get method will already sense that the builtin source
+command was invoked and handle it. This method is provided if the
+caller wishes to call this internally for some reason.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $file
+
+Filename to source
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Returns the result of the last command executed
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ unless (-f $file) {
+ error "Unable to open file $file - $!";
+ return;
+ } # unless
+
+ open my $source, '<', $file;
+
+ my $result;
+
+ $self->{sourcing} = 1;
+
+ my $i = 0;
+
+ while (<$source>) {
+ chomp;
+
+ $i++;
+
+ my $prompt = $self->{prompt};
+
+ $prompt =~ s/\\\#/$file:$i/;
+
+ display "$prompt$_" if $CmdLine::opts{trace};
+
+ next if /^\s*($|\#)/;
+
+ $_ = $self->_interpolate ($_);
+
+ # Check to see if it's a builtin
+ my ($cmd, $line, $result) = $self->_builtinCmds ($_);
+
+ next if $builtin_cmds{$cmd};
+
+ no strict;
+ $result = $self->{eval} ($line);
+ use strict;
+
+ if (defined $result) {
+ if (ref \$result eq 'SCALAR') {
+ PageOutput (split /\n/, $result);
+ } else {
+ display "Sorry but I cannot display structured results";
+ } # if
+ } # if
+ } # while
+
+ $self->{sourcing} = 0;
+
+ close $source;
+
+ return $result;
+} # source
+
+sub DESTROY {
+ my ($self) = @_;
+
+ $_cmdline->WriteHistory ($self->{histfile})
+ if $_cmdline and $_haveGnu;
+} # DESTROY
+
+our $cmdline = CmdLine->new;
+
+1;
+
+=pod
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+=head2 ClearSCM Perl Modules
+
+=for html <p><a href="/php/cvs_man.php?file=lib/Display.pm">Display</a></p>
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this module
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2007, ClearSCM, Inc. All rights reserved.
+
+=cut
--- /dev/null
+=pod
+
+=head1 NAME $RCSfile: DateUtils.pm,v $
+
+Simple date/time utilities
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.32 $
+
+=item Created
+
+Thu Jan 5 11:06:49 PST 2006
+
+=item Modified
+
+$Date: 2013/02/21 05:01:17 $
+
+=back
+
+=head1 SYNOPSIS
+
+Simple date and time utilities for often used date/time functionality.
+
+ my $ymd = YMD;
+ my $ymdhm = YMDHM;
+ my $timestamp = timestamp;
+
+=head1 DESCRIPTION
+
+Often you just want to simply and quickly get date or date and time in
+a YMD or YMDHM format. Note the YMDHM format defined here is YMD\@H:M
+and is not well suited for a filename. The timestamp routine returns
+YMD_HM.
+
+=head1 ROUTINES
+
+The following routines are exported:
+
+=cut
+
+package DateUtils;
+
+use strict;
+use warnings;
+
+use base 'Exporter';
+
+use Carp;
+use Time::Local;
+
+use Display;
+use Utils;
+
+our @EXPORT = qw (
+ Add
+ Age
+ Compare
+ DateToEpoch
+ EpochToDate
+ FormatDate
+ FormatTime
+ MDY
+ SQLDatetime2UnixDatetime
+ SubtractDays
+ Today2SQLDatetime
+ UnixDatetime2SQLDatetime
+ UTCTime
+ YMD
+ YMDHM
+ YMDHMS
+ timestamp
+ ymdhms
+);
+
+my @months = (
+ 31, # January
+ 28, # February
+ 31, # March
+ 30, # April
+ 31, # May
+ 30, # June
+ 31, # July
+ 31, # August
+ 30, # September
+ 31, # October
+ 30, # November
+ 31 # Descember
+);
+
+my $SECS_IN_MIN = 60;
+my $SECS_IN_HOUR = $SECS_IN_MIN * 60;
+my $SECS_IN_DAY = $SECS_IN_HOUR * 24;
+
+# Forwards
+sub Today2SQLDatetime ();
+sub DateToEpoch ($);
+sub EpochToDate ($);
+
+sub ymdhms {
+ my ($time) = @_;
+
+ $time ||= time;
+
+ my (
+ $sec,
+ $min,
+ $hour,
+ $mday,
+ $mon,
+ $year,
+ $wday,
+ $yday,
+ $isdst
+ ) = localtime ($time);
+
+ # Adjust month
+ $mon++;
+
+ # Adjust year
+ $year += 1900;
+
+ # Zero preface month, day, hour and minute
+ $mon = '0' . $mon if $mon < 10;
+ $mday = '0' . $mday if $mday < 10;
+ $hour = '0' . $hour if $hour < 10;
+ $min = '0' . $min if $min < 10;
+ $sec = '0' . $sec if $sec < 10;
+
+ return $year, $mon, $mday, $hour, $min, $sec;
+} # ymdhms
+
+sub julian ($$$) {
+ my ($year, $month, $day) = @_;
+
+ my $days = 0;
+ my $m = 1;
+
+ foreach (@months) {
+ last if $m >= $month;
+ $m++;
+ $days += $_;
+ } # foreach
+
+ return $days + $day;
+} # julian
+
+sub _is_leap_year ($) {
+ my ($year) = @_;
+
+ return 0 if $year % 4;
+ return 1 if $year % 100;
+ return 0 if $year % 400;
+
+ return 1;
+} # _is_leap_year
+
+sub Add ($%) {
+ my ($datetime, %parms) = @_;
+
+=pod
+
+=head2 Add ($datetime, %parms)
+
+Add to a datetime
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $datetime
+
+Datetime in SQLDatetime format to manipulate.
+
+=item %parms
+
+Hash of parms. Acceptable values are of the following format:
+
+ seconds => $seconds
+ minutes => $minutes
+ hours => $hours
+ days => $days
+ month => $month
+
+Note that month will simply increment the month number, adjusting for overflow
+of year if appropriate. Therefore a date of 2/28/2001 would increase by 1 month
+to yield 3/28/2001. And, unfortunately, an increase of 1 month to 1/30/2011
+would incorrectly yeild 2/30/2011!
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item New datetime
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my @validKeys = (
+ 'seconds',
+ 'minutes',
+ 'hours',
+ 'days',
+ 'months',
+ );
+
+ foreach (keys %parms) {
+ unless (InArray ($_, @validKeys)) {
+ croak "Invalid key in DateUtils::Add: $_";
+ } # unless
+ } # foreach
+
+ my $epochTime = DateToEpoch $datetime;
+
+ my $amount = 0;
+
+ $parms{seconds} ||= 0;
+ $parms{minutes} ||= 0;
+ $parms{hours} ||= 0;
+ $parms{days} ||= 0;
+
+ $amount += $parms{days} * $SECS_IN_DAY;
+ $amount += $parms{hours} * $SECS_IN_HOUR;
+ $amount += $parms{minutes} * $SECS_IN_MIN;
+ $amount += $parms{seconds};
+
+ $epochTime += $amount;
+
+ $datetime = EpochToDate $epochTime;
+
+ if ($parms{month}) {
+ my $years = $parms{month} / 12;
+ my $months = $parms{month} % 12;
+
+ my $month = substr $datetime, 5, 2;
+
+ $years += ($month + $months) / 12;
+ substr ($datetime, 5, 2) = ($month + $months) % 12;
+
+ substr ($datetime, 0, 4) = substr ($datetime, 0, 4) + $years;
+ } # if
+
+ return $datetime;
+} # Add
+
+sub Age ($) {
+ my ($timestamp) = @_;
+
+=pod
+
+=head2 Age ($timestamp)
+
+Determines how old something is given a timestamp
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $timestamp:
+
+Timestamp to age from (Assumed to be earlier than today)
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Number of days between $timestamp and today
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my $today = Today2SQLDatetime;
+ my $today_year = substr $today, 0, 4;
+ my $month = substr $today, 5, 2;
+ my $day = substr $today, 8, 2;
+ my $today_days = julian $today_year, $month, $day;
+
+ my $timestamp_year = substr $timestamp, 0, 4;
+ $month = substr $timestamp, 5, 2;
+ $day = substr $timestamp, 8, 2;
+ my $timestamp_days = julian $timestamp_year, $month, $day;
+
+ if ($timestamp_year > $today_year or
+ ($timestamp_days > $today_days and $timestamp_year == $today_year)) {
+ return;
+ } else {
+ my $leap_days = 0;
+
+ for (my $i = $timestamp_year; $i < $today_year; $i++) {
+
+ $leap_days++ if $i % 4 == 0;
+ } # for
+
+ $today_days += 365 * ($today_year - $timestamp_year) + $leap_days;
+ return $today_days - $timestamp_days;
+ } # if
+} # Age
+
+sub Compare ($$) {
+ my ($date1, $date2) = @_;
+
+=pod
+
+=head2 Compare ($date2, $date2)
+
+Compares two datetimes returning -1 if $date1 < $date2, 0 if equal or 1 if
+$date1 > $date2
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $date1
+
+Date 1 to compare
+
+=item $date2
+
+Date 2 to compare
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item -1 if $date1 < $date2, 0 if equal or 1 if $date1 > $date2
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return DateToEpoch ($date1) <=> DateToEpoch ($date2);
+} # Compare
+
+sub DateToEpoch ($) {
+ my ($date) = @_;
+
+=pod
+
+=head2 DateToEpoch ($datetime)
+
+Converts a datetime to epoch
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $datetime
+
+Datetime to convert to an epoch
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $epoch
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my $year = substr $date, 0, 4;
+ my $month = substr $date, 5, 2;
+ my $day = substr $date, 8, 2;
+ my $hour = substr $date, 11, 2;
+ my $minute = substr $date, 14, 2;
+ my $seconds = substr $date, 17, 2;
+
+ my $days;
+
+ for (my $i = 1970; $i < $year; $i++) {
+ $days += _is_leap_year ($i) ? 366 : 365;
+ } # for
+
+ my @monthDays = (
+ 0,
+ 31,
+ 59,
+ 90,
+ 120,
+ 151,
+ 181,
+ 212,
+ 243,
+ 273,
+ 304,
+ 334,
+ );
+
+ $days += $monthDays[$month - 1];
+
+ $days++
+ if _is_leap_year ($year) and $month > 2;
+
+ $days += $day - 1;
+
+ return ($days * $SECS_IN_DAY)
+ + ($hour * $SECS_IN_HOUR)
+ + ($minute * $SECS_IN_MIN)
+ + $seconds;
+} # DateToEpoch
+
+sub EpochToDate ($) {
+ my ($epoch) = @_;
+
+=pod
+
+=head2 EpochToDate ($epoch)
+
+Converts an epoch to a datetime
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $epoch
+
+Epoch to convert to a datetime
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $datetime
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my $year = 1970;
+ my ($month, $day, $hour, $minute, $seconds);
+ my $leapYearSecs = 366 * $SECS_IN_DAY;
+ my $yearSecs = $leapYearSecs - $SECS_IN_DAY;
+
+ while () {
+ my $amount = _is_leap_year ($year) ? $leapYearSecs : $yearSecs;
+
+ last
+ if $amount > $epoch;
+
+ $epoch -= $amount;
+ $year++;
+ } # while
+
+ my $leapYearAdjustment = _is_leap_year ($year) ? 1 : 0;
+
+ if ($epoch >= (334 + $leapYearAdjustment) * $SECS_IN_DAY) {
+ $month = '12';
+ $epoch -= (334 + $leapYearAdjustment) * $SECS_IN_DAY;
+ } elsif ($epoch >= (304 + $leapYearAdjustment) * $SECS_IN_DAY) {
+ $month = '11';
+ $epoch -= (304 + $leapYearAdjustment) * $SECS_IN_DAY;
+ } elsif ($epoch >= (273 + $leapYearAdjustment) * $SECS_IN_DAY) {
+ $month = '10';
+ $epoch -= (273 + $leapYearAdjustment) * $SECS_IN_DAY;
+ } elsif ($epoch >= (243 + $leapYearAdjustment) * $SECS_IN_DAY) {
+ $month = '09';
+ $epoch -= (243 + $leapYearAdjustment) * $SECS_IN_DAY;
+ } elsif ($epoch >= (212 + $leapYearAdjustment) * $SECS_IN_DAY) {
+ $month = '08';
+ $epoch -= (212 + $leapYearAdjustment) * $SECS_IN_DAY;
+ } elsif ($epoch >= (181 + $leapYearAdjustment) * $SECS_IN_DAY) {
+ $month = '07';
+ $epoch -= (181 + $leapYearAdjustment) * $SECS_IN_DAY;
+ } elsif ($epoch >= (151 + $leapYearAdjustment) * $SECS_IN_DAY) {
+ $month = '06';
+ $epoch -= (151 + $leapYearAdjustment) * $SECS_IN_DAY;
+ } elsif ($epoch >= (120 + $leapYearAdjustment) * $SECS_IN_DAY) {
+ $month = '05';
+ $epoch -= (120 + $leapYearAdjustment) * $SECS_IN_DAY;
+ } elsif ($epoch >= (90 + $leapYearAdjustment) * $SECS_IN_DAY) {
+ $month = '04';
+ $epoch -= (90 + $leapYearAdjustment) * $SECS_IN_DAY;
+ } elsif ($epoch >= (59 + $leapYearAdjustment) * $SECS_IN_DAY) {
+ $month = '03';
+ $epoch -= (59 + $leapYearAdjustment) * $SECS_IN_DAY;
+ } elsif ($epoch >= 31 * $SECS_IN_DAY) {
+ $month = '02';
+ $epoch -= 31 * $SECS_IN_DAY;
+ } else {
+ $month = '01';
+ } # if
+
+ $day = int (($epoch / $SECS_IN_DAY) + 1);
+ $epoch = $epoch % $SECS_IN_DAY;
+ $hour = int ($epoch / $SECS_IN_HOUR);
+ $epoch = $epoch % $SECS_IN_HOUR;
+ $minute = int ($epoch / $SECS_IN_MIN);
+ $seconds = $epoch % $SECS_IN_MIN;
+
+ $day = "0$day" if $day < 10;
+ $hour = "0$hour" if $hour < 10;
+ $minute = "0$minute" if $minute < 10;
+ $seconds = "0$seconds" if $seconds < 10;
+
+ return "$year-$month-$day $hour:$minute:$seconds";
+} # EpochToDate
+
+sub UTCTime ($) {
+ my ($datetime) = @_;
+
+=pod
+
+=head2 UTCTime ($epoch)
+
+Converts an epoch to UTC Time
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $epoch
+
+Epoch to convert to a datetime
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $datetime
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my @localtime = localtime;
+ my ($sec, $min, $hour, $mday, $mon, $year) = gmtime (
+ DateToEpoch ($datetime) - (timegm (@localtime) - timelocal (@localtime))
+ );
+
+ $year += 1900;
+ $mon++;
+
+ $sec = '0' . $sec if $sec < 10;
+ $min = '0' . $min if $min < 10;
+ $hour = '0' . $hour if $hour < 10;
+ $mon = '0' . $mon if $mon < 10;
+ $mday = '0' . $mday if $mday < 10;
+
+ return "$year-$mon-${mday}T$hour:$min:${sec}Z";
+} # UTCTime
+
+sub UTC2Localtime ($) {
+ my ($utcdatetime) = @_;
+
+ # If the field does not look like a UTC time then just return it.
+ return $utcdatetime unless $utcdatetime =~ /\d{4}-\d{2}-\d{2}T\d{2}:\d{2}:\d{2}Z/;
+
+ $utcdatetime =~ s/T/ /;
+ $utcdatetime =~ s/Z//;
+
+ my @localtime = localtime;
+
+ return EpochToDate (
+ DateToEpoch ($utcdatetime) + (timegm (@localtime) - timelocal (@localtime))
+ );
+} # UTC2Localtime
+
+sub FormatDate ($) {
+ my ($date) = @_;
+
+=pod
+
+=head2 FormatDate ($date)
+
+Formats date
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $date:
+
+Date in YYYYMMDD
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Returns a date in MM/DD/YYYY format
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return substr ($date, 4, 2)
+ . "/"
+ . substr ($date, 6, 2)
+ . "/"
+ . substr ($date, 0, 4);
+} # FormatDate
+
+sub FormatTime ($) {
+ my ($time) = @_;
+
+=pod
+
+=head2 FormatTime ($time)
+
+Formats Time
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $time:
+
+Time in in HH:MM format (24 hour format)
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Time in HH:MM [Am|Pm] format
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my $hours = substr $time, 0, 2;
+ my $minutes = substr $time, 3, 2;
+ my $AmPm = $hours > 12 ? "Pm" : "Am";
+
+ $hours = $hours - 12 if $hours > 12;
+
+ return "$hours:$minutes $AmPm";
+} # FormatTime
+
+sub MDY (;$) {
+ my ($time) = @_;
+
+=pod
+
+=head2 MDY ($time)
+
+Returns MM/DD/YYYY for $time
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $time:
+
+Time in Unix time format (Default: current time)
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Date in MM/DD/YYYY
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my ($year, $mon, $mday) = ymdhms $time;
+
+ return "$mon/$mday/$year";
+} # MDY
+
+sub SQLDatetime2UnixDatetime ($) {
+ my ($sqldatetime) = @_;
+
+=pod
+
+=head2 SQLDatetime2UnixDatetime ($sqldatetime)
+
+Converts an SQL formatted date to a Unix (localtime) formatted date)
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $sqldatetime:
+
+Date and time stamp in SQL format
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Returns a Unix formated date and time (a la localtime)
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my %months = (
+ "01" => "Jan",
+ "02" => "Feb",
+ "03" => "Mar",
+ "04" => "Apr",
+ "05" => "May",
+ "06" => "Jun",
+ "07" => "Jul",
+ "08" => "Aug",
+ "09" => "Sep",
+ "10" => "Oct",
+ "11" => "Nov",
+ "12" => "Dec"
+ );
+
+ my $year = substr $sqldatetime, 0, 4;
+ my $month = substr $sqldatetime, 5, 2;
+ my $day = substr $sqldatetime, 8, 2;
+ my $time = FormatTime (substr $sqldatetime, 11);
+
+ return $months{$month} . " $day, $year \@ $time";
+} # SQLDatetime2UnixDatetime
+
+sub SubtractDays ($$) {
+ my ($timestamp, $nbr_of_days) = @_;
+
+=pod
+
+=head2 SubtractDays ($timestamp, $nbr_of_days)
+
+Subtracts $nbr_of_days from $timestamp
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $timestamp:
+
+Timestamp to subtract days from
+
+=back
+
+=over
+
+=item $nbr_of_days:
+
+=back
+
+Number of days to subtract from $timestamp
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item SQL format date $nbr_of_days ago
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my $year = substr $timestamp, 0, 4;
+ my $month = substr $timestamp, 5, 2;
+ my $day = substr $timestamp, 8, 2;
+
+ # Convert to Julian
+ my $days = julian $year, $month, $day;
+
+ # Subtract $nbr_of_days
+ $days -= $nbr_of_days;
+
+ # Compute $days_in_year
+ my $days_in_year;
+
+ # Adjust if crossing year boundary
+ if ($days <= 0) {
+ $year--;
+ $days_in_year = (($year % 4) == 0) ? 366 : 365;
+ $days = $days_in_year + $days;
+ } else {
+ $days_in_year = (($year % 4) == 0) ? 366 : 365;
+ } # if
+
+ # Convert back
+ $month = 0;
+
+ while ($days > 28) {
+ # If remaining days is less than the current month then last
+ last if ($days <= $months[$month]);
+
+ # Subtract off the number of days in this month
+ $days -= $months[$month++];
+ } # while
+
+ # Prefix month with 0 if necessary
+ $month++;
+ if ($month < 10) {
+ $month = "0" . $month;
+ } # if
+
+ # Prefix days with 0 if necessary
+ if ($days == 0) {
+ $days = "01";
+ } elsif ($days < 10) {
+ $days = "0" . $days;
+ } # if
+
+ return $year . "-" . $month . "-" . $days . substr $timestamp, 10;
+} # SubtractDays
+
+sub Today2SQLDatetime () {
+
+=pod
+
+=head2 Today2SQLDatetime ($datetime)
+
+Returns today's date in an SQL format
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item None
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item SQL formated time stamp for today
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return UnixDatetime2SQLDatetime (scalar (localtime));
+} # Today2SQLDatetime
+
+sub UnixDatetime2SQLDatetime ($) {
+ my ($datetime) = @_;
+
+=pod
+
+=head2 UnixDatetime2SQLDatetime ($datetime)
+
+Converts a Unix (localtime) date/time stamp to an SQL formatted
+date/time stamp
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $datetime:
+
+Unix formated date time stamp
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item SQL formated time stamp
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my $orig_datetime = $datetime;
+ my %months = (
+ Jan => '01',
+ Feb => '02',
+ Mar => '03',
+ Apr => '04',
+ May => '05',
+ Jun => '06',
+ Jul => '07',
+ Aug => '08',
+ Sep => '09',
+ Oct => '10',
+ Nov => '11',
+ Dec => '12',
+ );
+
+ # Some mailers neglect to put the leading day of the week field in.
+ # Check for this and compensate.
+ my $dow = substr $datetime, 0, 3;
+
+ if ($dow ne 'Mon' and
+ $dow ne 'Tue' and
+ $dow ne 'Wed' and
+ $dow ne 'Thu' and
+ $dow ne 'Fri' and
+ $dow ne 'Sat' and
+ $dow ne 'Sun') {
+ $datetime = 'XXX, ' . $datetime;
+ } # if
+
+ # Some mailers have day before month. We need to correct this
+ my $day = substr $datetime, 5, 2;
+
+ if ($day =~ /\d /) {
+ $day = '0' . (substr $day, 0, 1);
+ $datetime = (substr $datetime, 0, 5) . $day . (substr $datetime, 6);
+ } # if
+
+ if ($day !~ /\d\d/) {
+ $day = substr $datetime, 8, 2;
+ } # if
+
+ # Check for 1 digit date
+ if ((substr $day, 0, 1) eq ' ') {
+ $day = '0' . (substr $day, 1, 1);
+ $datetime = (substr $datetime, 0, 8) . $day . (substr $datetime, 10);
+ } elsif ((substr $day, 1, 1) eq ' ') {
+ $day = '0' . (substr $day, 0, 1);
+ $datetime = (substr $datetime, 0, 8) . $day . (substr $datetime, 9);
+ } # if
+
+ my $year = substr $datetime, 20, 4;
+
+ if ($year !~ /\d\d\d\d/) {
+ $year = substr $datetime, 12, 4;
+ if ($year !~ /\d\d\d\d/) {
+ $year = substr $datetime, 12, 2;
+ } #if
+ } # if
+
+ # Check for 2 digit year. Argh!
+ if (length $year == 2 or (substr $year, 2, 1) eq ' ') {
+ $year = '20' . (substr $year, 0, 2);
+ $datetime = (substr $datetime, 0, 12) . '20' . (substr $datetime, 12);
+ } # if
+
+ my $month_name = substr $datetime, 4, 3;
+
+ unless ($months{$month_name}) {
+ $month_name = substr $datetime, 8, 3;
+ } # unless
+
+ my $month = $months{$month_name};
+ my $time = substr $datetime, 11, 8;
+
+ if ($time !~ /\d\d:\d\d:\d\d/) {
+ $time = substr $datetime, 17, 8
+ } # if
+
+ unless ($year) {
+ warning "Year undefined for $orig_datetime\nReturning today's date";
+ return Today2SQLDatetime;
+ } # unless
+
+ unless ($month) {
+ warning "Month undefined for $orig_datetime\nReturning today's date";
+ return Today2SQLDatetime;
+ } # unless
+
+ unless ($day) {
+ warning "Day undefined for $orig_datetime\nReturning today's date";
+ return Today2SQLDatetime;
+ } # unless
+
+ unless ($time) {
+ warning "Time undefined for $orig_datetime\nReturning today's date";
+ return Today2SQLDatetime;
+ } # unless
+
+ return "$year-$month-$day $time";
+} # UnixDatetime2SQLDatetime
+
+sub YMD (;$) {
+ my ($time) = @_;
+
+=pod
+
+=head2 YMD ($time)
+
+Returns the YMD in a format of YYYYMMDD
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $time:
+
+Time to convert to YYYYMMDD (Default: Current time)
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Date in YYYYMMDD format
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my ($year, $mon, $mday) = ymdhms $time;
+
+ return "$year$mon$mday";
+} # YMD
+
+sub YMDHM (;$) {
+ my ($time) = @_;
+
+=pod
+
+=head2 YMDHM ($time)
+
+Returns the YMD in a format of YYYYMMDD@HH:MM
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $time:
+
+Time to convert to YYYYMMDD@HH:MM (Default: Current time)
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Date in YYYYMMDD@HH:MM format
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my ($year, $mon, $mday, $hour, $min) = ymdhms $time;
+
+ return "$year$mon$mday\@$hour:$min";
+} # YMDHM
+
+sub YMDHMS (;$) {
+ my ($time) = @_;
+
+=pod
+
+=head2 YMDHMS ($time)
+
+Returns the YMD in a format of YYYYMMDD@HH:MM:SS
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $time:
+
+Time to convert to YYYYMMDD@HH:MM:SS (Default: Current time)
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Date in YYYYMMDD@HH:MM:SS format
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my ($year, $mon, $mday, $hour, $min, $sec) = ymdhms $time;
+
+ return "$year$mon$mday\@$hour:$min:$sec";
+} # YMDHMS
+
+sub timestamp (;$) {
+ my ($time) = @_;
+
+=pod
+
+=head2 timestamp ($time)
+
+Returns the YMD in a format of YYYYMMDD_HHMM
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $time:
+
+Time to convert to YYYYMMDD_HHMMSS (Default: Current time)
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Date in YYYYMMDD_HHMMSS format
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my ($year, $mon, $mday, $hour, $min, $sec) = ymdhms $time;
+
+ return "$year$mon${mday}_$hour$min$sec";
+} # timestamp
+
+1;
+
+=head2 DEPENDENCIES
+
+=head3 Perl Modules
+
+=for html <p><a href="/php/cvs_man.php?file=lib/Display.pm">Display</a></p>
+
+=head1 INCOMPATABILITIES
+
+None yet...
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this module.
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+This Perl Module is freely available; you can redistribute it and/or
+modify it under the terms of the GNU General Public License as
+published by the Free Software Foundation; either version 2 of the
+License, or (at your option) any later version.
+
+This Perl Module is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License (L<http://www.gnu.org/copyleft/gpl.html>) for more
+details.
+
+You should have received a copy of the GNU General Public License
+along with this Perl Module; if not, write to the Free Software Foundation,
+Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+reserved.
+
+=cut
--- /dev/null
+=pod
+
+=head1 NAME $RCSfile: Display.pm,v $
+
+Simple and consistant display routines for Perl
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.45 $
+
+=item Created
+
+Fri Mar 12 10:17:44 PST 2004
+
+=item Modified
+
+$Date: 2013/05/30 15:48:06 $
+
+=back
+
+=head1 SYNOPSIS
+
+This module seeks to make writing output simpler and more consistant. Messages
+are classified as display (informational - always displayed), verbose (written
+only if $verbose is set) and debug (written only if $debug is set). There are
+also routines for error(s) and warning(s) which support optional parameters for
+error number and warning number. If error number is specified then the process
+is also terminated.
+
+ display "message";
+ verbose "$n records processed";
+ verbose2 "Processing record #$recno";
+ warning "Unable to find record", 1;
+ debug "Reached here...";
+ error "Can't continue", 2;
+
+=head2 DESCRIPTION
+
+This module implements several routines to provide and easy and
+consistant interface to writing output in Perl. Perl has lots of ways
+to do such things but these methods seek to be self explainitory and
+to provide convenient parameters and defaults so as to make coding
+easier.
+
+There are also some other routines, i.e. get_debug, that will return
+$debug in case you want to execute other Perl code only when
+debugging:
+
+ if (get_debug) {
+ foreach (@output_line) {
+ debug $_;
+ } # foreach
+ } # if
+
+By default these routines write lines complete with the terminating
+"\n". I find that this is most often what you are doing. There are
+corresponding <routine>_nolf versions for display and verbose in case
+you wish to not terminate lines. Or use the new say function.
+
+Also, routines like display support a file handle parameter if you
+wish to say display into a file - Default STDOUT.
+
+Both version and debug support levels and have convienence functions:
+verbose1, debug2. Three levels of conienence functions are supplied
+although an unlimited amount can be supported directly through
+verbose/debug. See documentaton for those functions for details.
+
+=head1 ROUTINES
+
+The following routines are exported:
+
+=cut
+
+package Display;
+
+use strict;
+use warnings;
+
+use base 'Exporter';
+
+use FindBin;
+use File::Spec;
+use Term::ANSIColor qw(color);
+use Carp;
+use Config;
+
+our @EXPORT = qw (
+ debug debug1 debug2 debug3
+ display
+ display_err
+ display_error
+ display_nolf
+ error
+ get_debug
+ get_me
+ get_trace
+ get_verbose
+ say
+ set_debug
+ set_me
+ set_trace
+ set_verbose
+ trace
+ trace_enter
+ trace_exit
+ verbose verbose1 verbose2 verbose3
+ verbose_nolf
+ warning
+);
+
+my ($me, $verbose, $debug, $trace);
+
+BEGIN {
+ $me = $FindBin::Script;
+ $me =~ s/\.pl$//;
+
+ $verbose = $ENV{VERBOSE};
+ $debug = $ENV{DEBUG};
+ $trace = $ENV{TRACE};
+} # BEGIN
+
+sub display_err ($;$$);
+
+sub debug ($;$$$) {
+ my ($msg, $handle, $nolinefeed, $level) = @_;
+
+=pod
+
+=head2 debug[1-3] ($msg, $handle, $nolinefeed, $level)
+
+Write $msg to $handle (default STDERR) with a "\n" unless $nolinefeed
+is defined. Messages are written only if written if $debug is set and
+=< $level. $level defaults to 1.
+
+debug1, debug2 and debug3 are setup as convienence functions that are
+equivalent to calling debug with $level set to 1, 2 or 3 respectively
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $msg:
+
+Message to display
+
+=item $handle:
+
+File handle to display to (Default: STDERR)
+
+=item $nolinefeed:
+
+If defined no linefeed is displayed at the end of the message.
+
+=item $level
+
+If defined, if $level =< $debug then the debug message is displayed.
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Nothing
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return
+ unless $debug;
+
+ return
+ if $debug == 0;
+
+ $level ||= 1;
+ $msg ||= '';
+
+ if (($handle and -t $handle) or (-t *STDERR)) {
+ $msg = color ('cyan')
+ . $me
+ . color ('reset')
+ . ": "
+ . color ('magenta')
+ . "DEBUG"
+ . color ('reset')
+ . ": $msg";
+ } else {
+ $msg = "$me: DEBUG: $msg";
+ } # if
+
+ display_err $msg, $handle, $nolinefeed if $debug and $level <= $debug;
+
+ return;
+} # debug
+
+sub debug1 ($;$$) {
+ my ($msg, $handle, $nolinefeed) = @_;
+
+ debug $msg, $handle, $nolinefeed, 1;
+
+ return;
+} # debug1
+
+sub debug2 ($;$$) {
+ my ($msg, $handle, $nolinefeed) = @_;
+
+ debug $msg, $handle, $nolinefeed, 2;
+
+ return;
+} # debug1
+
+sub debug3 ($;$$) {
+ my ($msg, $handle, $nolinefeed) = @_;
+
+ debug $msg, $handle, $nolinefeed, 2;
+
+ return;
+} # debug1
+
+sub display (;$$$) {
+ my ($msg, $handle, $nolinefeed) = @_;
+
+=pod
+
+=head2 display ($msg, $handle, $nolinefeed)
+
+Write $msg to $handle (default STDOUT) with a "\n" unless $nolinefeed
+is defined.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $msg:
+
+Message to display
+
+=item $handle:
+
+File handle to display to (Default: STDOUT)
+
+=item $nolinefeed:
+
+If defined no linefeed is displayed at the end of the message.
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Nothing
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $msg ||= '';
+ $handle = *STDOUT unless $handle;
+
+ print $handle $msg;
+ print $handle "\n" unless $nolinefeed;
+
+ return;
+} # display
+
+sub display_err ($;$$) {
+ my ($msg, $handle, $nolinefeed) = @_;
+
+=pod
+
+=head2 display_err ($msg, $handle, $nolinefeed)
+
+Displays $msg to STDERR
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $msg:
+
+Message to display
+
+=item $handle:
+
+File handle to display to (Default: STDOUT)
+
+=item $nolinefeed:
+
+If defined no linefeed is displayed at the end of the message.
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Nothing
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $msg ||= '';
+ $handle = *STDERR if !$handle;
+
+ print $handle $msg;
+ print $handle "\n" if !$nolinefeed;
+
+ return;
+} # display_err
+
+sub display_error ($;$$$) {
+ my ($msg, $errno, $handle, $nolinefeed) = @_;
+
+=pod
+
+=head2 display_error ($msg, $errno, $handle, $nolinefeed)
+
+Displays colorized $msg to STDERR
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $msg:
+
+Message to display
+
+=item $errno
+
+Error no to display (if any)
+
+=item $handle:
+
+File handle to display to (Default: STDOUT)
+
+=item $nolinefeed:
+
+If defined no linefeed is displayed at the end of the message.
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Nothing
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $msg ||= '';
+
+ unless ($errno) {
+ if (($handle and -t $handle) or (-t *STDERR) and ($Config{perl} ne 'ratlperl')) {
+ $msg = color ('cyan')
+ . $me
+ . color ('reset')
+ . ": "
+ . color ('red')
+ . "ERROR"
+ . color ('reset')
+ . ": $msg";
+ } else {
+ $msg = "$me: ERROR: $msg";
+ } # if
+ } else {
+ if (($handle and -t $handle) or (-t *STDERR) and ($Config{perl} ne 'ratlperl')) {
+ $msg = color ('cyan')
+ . $me
+ . color ('reset')
+ . ": "
+ . color ('red')
+ . "ERROR #$errno"
+ . color ('reset')
+ . ": $msg";
+ } else {
+ $msg = "$me: ERROR #$errno: $msg";
+ } # if
+ } # if
+
+ display_err $msg, $handle, $nolinefeed;
+
+ return;
+} # display_error
+
+sub display_nolf ($;$) {
+ my ($msg, $handle) = @_;
+
+=pod
+
+=head2 display_nolf ($msg, $handle)
+
+Equivalent of display ($msg, $handle, "nolf").
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $msg:
+
+Message to display
+
+=item $handle:
+
+File handle to display to (Default: STDOUT)
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Nothing
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ display $msg, $handle, "nolf";
+
+ return;
+} # display_nolf
+
+sub error ($;$$$) {
+ my ($msg, $errno, $handle, $nolinefeed) = @_;
+
+=pod
+
+=head2 error ($msg, $errno, $handle, $nolinefeed)
+
+Write $msg to $handle (default STDERR) with a "\n" unless $nolinefeed
+is defined. Preface message with "<script name>: ERROR: " so that
+error messages are clearly distinguishable. If $errno is specified it
+is included and the process it terminated with the exit status set to
+$errno.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $msg:
+
+Message to display
+
+=item $handle:
+
+File handle to display to (Default: STDOUT)
+
+=item $nolinefeed:
+
+If defined no linefeed is displayed at the end of the message.
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Nothing
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ display_error $msg, $errno, $handle, $nolinefeed;
+
+ exit $errno if $errno;
+
+ return;
+} # error
+
+sub get_debug {
+
+=pod
+
+=head2 get_debug
+
+Returns $debug.
+
+Parameters:
+
+=for html <blockquote>
+
+None
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $debug
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $debug;
+} # get_debug
+
+sub get_trace {
+
+=pod
+
+=head2 get_trace
+
+Returns $trace.
+
+Parameters:
+
+=for html <blockquote>
+
+None
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $trace
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $trace;
+} # get_trace
+
+sub get_verbose {
+
+=pod
+
+=head2 get_verbose
+
+Returns $verbose.
+
+Parameters:
+
+=for html <blockquote>
+
+None
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $verbose
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $verbose;
+} # set_verbose
+
+sub set_debug {
+ my ($newValue) = @_;
+
+=pod
+
+=head2 set_debug
+
+Sets $debug.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item newValue
+
+New value to set $verbose to. If not specified then $verbose is set to
+1. The only other sensible value would be 0 to turn off verbose.
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Old setting of $verbose
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my $returnValue = $debug ? $debug : 0;
+
+ $debug = defined $newValue ? $newValue : 1;
+
+ return $returnValue;
+} # set_debug
+
+sub get_me () {
+
+=pod
+
+=head2 get_me ($me)
+
+Gets $me which is used by error. Module automatically calculates the
+basename of the script that called it.
+
+Parameters:
+
+=over
+
+=item none
+
+=back
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $me
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $me;
+} # get_me
+
+sub set_me {
+ my ($whoami) = @_;
+
+=pod
+
+=head2 set_me ($me)
+
+Sets $me which is used by error. Module automatically calculates the
+basename of the script that called it.
+
+Parameters:
+
+=over
+
+=item $me
+
+String to set $me as
+
+=back
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Nothing
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $me = $whoami;
+
+ return;
+} # set_me
+
+sub set_trace (;$) {
+ my ($newValue) = @_;
+
+=pod
+
+=head2 set_trace
+
+Sets $trace.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item newValue
+
+New value to set $trace to. If not specified then $trace is set to
+1. The only other sensible value would be 0 to turn off trace.
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Old setting of $trace
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my $returnValue = $trace ? $trace : 0;
+
+ $trace = defined $newValue ? $newValue : 1;
+
+ return $returnValue;
+} # set_trace
+
+sub set_verbose (;$) {
+ my ($newValue) = @_;
+
+=pod
+
+=head2 set_verbose
+
+Sets $verbose.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item newValue
+
+New value to set $verbose to. If not specified then $verbose is set to
+1. The only other sensible value would be 0 to turn off verbose.
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Old setting of $verbose
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my $returnValue = $verbose ? $verbose : 0;
+
+ $verbose = defined $newValue ? $newValue : 1;
+
+ return $returnValue;
+} # set_verbose
+
+sub trace (;$$) {
+ my ($msg, $type) = @_;
+
+=pod
+
+=head2 trace
+
+Emit trace statements from within a subroutine
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item msg
+
+Optional message to display
+
+=item type
+
+Optional prefix to message. Used by trace_enter and trace_exit. If not
+specified the string "In " is used.
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Name of the calling subroutine, if known
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return
+ unless $trace;
+
+ $msg = $msg ? ": $msg" : '';
+ $type ||= 'In';
+
+ croak 'Type should be ENTER, EXIT or undef'
+ unless $type eq 'ENTER' ||
+ $type eq 'EXIT' ||
+ $type eq 'In';
+
+ my $stack = $type eq 'In' ? 1 : 2;
+
+ my ($package, $filename, $line, $subroutine) = caller ($stack);
+
+ if ($subroutine) {
+ $subroutine =~ s/^main:://
+ } else {
+ $subroutine = 'main';
+ } # if
+
+ if (-t STDOUT) {
+ display color ('cyan')
+ . "$type "
+ . color ('yellow')
+ . color ('bold')
+ . $subroutine
+ . color ('reset')
+ . $msg;
+ } else {
+ display "$type $subroutine$msg";
+ } # if
+
+ return $subroutine;
+} # trace
+
+sub trace_enter (;$) {
+ my ($msg) = @_;
+
+=pod
+
+=head2 trace_enter
+
+Emit enter trace for a subroutine
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item msg
+
+Optional message to display along with "ENTER <sub>"
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Name of the calling subroutine, if known
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return trace $msg, "ENTER";
+} # trace_enter
+
+sub trace_exit (;$) {
+ my ($msg) = @_;
+
+=pod
+
+=head2 trace_exit
+
+Emit exit trace for a subroutine
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item msg
+
+Optional message to display along with "EXIT <sub>". Useful in
+distinguishing multiple exit/returns.
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ trace $msg, "EXIT";
+
+ return
+} # trace_exit
+
+sub verbose ($;$$$) {
+ my ($msg, $handle, $nolinefeed, $level) = @_;
+
+=pod
+
+=head2 verbose[1-3] ($msg, $handle, $nolinefeed, $level)
+
+Write $msg to $handle (default STDOUT) with a "\n" unless $nolinefeed
+is defined. Messages are written only if written if $verbose is set
+and <= $level. $level defaults to 1.
+
+verbose1, verbose2 and verbose3 are setup as convienence functions
+that are equivalent to calling verbose with $level set to 1, 2 or 3
+respectively
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $msg
+
+Message to display
+
+=item $handle
+
+File handle to display to (Default: STDOUT)
+
+=item $nolinefeed
+
+If defined no linefeed is displayed at the end of the message.
+
+=item $level
+
+If defined, if $level <= $verbose then the verbose message is
+displayed.
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Nothing
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $level ||= 1;
+ $verbose ||= 0;
+
+ display $msg, $handle, $nolinefeed if $verbose and $level <= $verbose;
+
+ return;
+} # verbose
+
+sub verbose1 ($;$$) {
+ my ($msg, $handle, $nolinefeed) = @_;
+
+ verbose $msg, $$handle, $nolinefeed, 1;
+
+ return;
+} # verbose1
+
+sub verbose2 ($;$$) {
+ my ($msg, $handle, $nolinefeed) = @_;
+
+ verbose $msg, $handle, $nolinefeed, 2;
+
+ return;
+} # verbose1
+
+sub verbose3 ($;$$) {
+ my ($msg, $handle, $nolinefeed) = @_;
+
+ verbose $msg, $handle, $nolinefeed, 3;
+
+ return;
+} # verbose1
+
+sub verbose_nolf ($;$) {
+ my ($msg, $handle) = @_;
+
+=pod
+
+=head2 verbose_nolf ($msg, $handle)
+
+Equivalent of verbose ($msg, $handle, "nolf")
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $msg
+
+Message to display
+
+=item $handle
+
+File handle to display to (Default: STDOUT)
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Nothing
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ verbose $msg, $handle, "nolf";
+
+ return;
+} # verbose_nolf
+
+sub warning ($;$$$) {
+ my ($msg, $warnno, $handle, $nolinefeed) = @_;
+
+=pod
+
+=head2 warning ($msg, $handle, $nolinefeed)
+
+Write $msg to $handle (default STDERR) with a "\n" unless $nolinefeed
+is defined. Preface message with "<script name>: WARNING: " so that
+warning messages are clearly distinguishable.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $msg:
+
+Message to display
+
+=item $handle:
+
+File handle to display to (Default: STDOUT)
+
+=item $nolinefeed:
+
+If defined no linefeed is displayed at the end of the message.
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Nothing
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $msg ||= '';
+
+ unless ($warnno) {
+ if (($handle and -t $handle) or (-t *STDERR) and ($Config{perl} ne 'ratlperl')) {
+ $msg = color ('cyan')
+ . $me
+ . color ('reset')
+ . ": "
+ . color ('yellow')
+ . "WARNING"
+ . color ('reset')
+ . ": $msg";
+ } else {
+ $msg = "$me: WARNING: $msg";
+ } # if
+ } else {
+ if (($handle and -t $handle) or (-t *STDERR) and ($Config{perl} ne 'ratlperl')) {
+ $msg = color ('cyan')
+ . $me
+ . color ('reset')
+ . ": "
+ . color ('yellow')
+ . "WARNING #$warnno"
+ . color ('reset')
+ . ": $msg";
+ } else {
+ $msg = "$me: WARNING #$warnno: $msg";
+ } # if
+ } # if
+
+ display_err $msg, $handle, $nolinefeed;
+
+ return;
+} # warning
+
+1;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<File::Spec|File::Spec>
+
+L<Term::ANSIColor|Term::ANSIColor>
+
+=head1 INCOMPATABILITIES
+
+None yet...
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this module.
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+This Perl Module is freely available; you can redistribute it and/or
+modify it under the terms of the GNU General Public License as
+published by the Free Software Foundation; either version 2 of the
+License, or (at your option) any later version.
+
+This Perl Module is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License (L<http://www.gnu.org/copyleft/gpl.html>) for more
+details.
+
+You should have received a copy of the GNU General Public License
+along with this Perl Module; if not, write to the Free Software Foundation,
+Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+reserved.
+
+=cut
--- /dev/null
+=pod
+
+=head1 NAME $RCSfile: GetConfig.pm,v $
+
+Simple config file parsing
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@DeFaria.com>
+
+=item Revision
+
+$Revision: 1.19 $
+
+=item Created
+
+Tue Feb 14 11:03:18 PST 2006
+
+=item Modified
+
+$Date: 2013/01/17 01:08:34 $
+
+=back
+
+=head1 SYNOPSIS
+
+Parse config files.
+
+ # Comment lines are skipped - white space is eliminated...
+ app: MyApp
+ nbr_iterrations: 10
+ major_version: 1
+ release: 2
+ version: $major_version.$release
+
+ my %opts = GetConfig "myconfig.cfg";
+ print "Application Name:\t" . $opts {app} . "(" . $opts {version} . )\n";
+ print "Iterrations:\t\t" . $opts {nbr_iterrations} . "\n";
+
+yields
+
+ Application Name: MyApp (1.2)
+ Iterrations: 10
+
+=head1 DESCRIPTION
+
+This module is a simple interface to reading config files. Config file
+format is roughly like .XDefaults format - <name>:<value> pairs. A
+hash of the name/value pairs are returned. Variable interpolation is
+supported such that env(1) variables will be interpolated as well as
+previously defined values. Thus:
+
+ temp_files: tmp
+ temp_dir: $HOME/$temp_files
+ temp_dir2: $HOME/$foo/$temp_files
+
+would return:
+
+ $conf{temp_files} => "tmp"
+ $conf{temp_dir} => "~/tmp"
+ $conf{temp_dir2} => "~/$foo/tmp"
+
+In other word, $HOME would be expanded because it's set in your
+environment and $temp_files would be expanded because you set it in
+the first line. Finally $foo would not be expanded because it was not
+set in the first place. This is useful if other processing wants to
+provide further interpolation.
+
+=head1 ROUTINES
+
+The following routines are exported:
+
+=cut
+
+package GetConfig;
+
+use strict;
+use warnings;
+
+use base 'Exporter';
+use File::Spec;
+use Carp;
+
+our @EXPORT = qw (
+ GetConfig
+);
+
+# Interpolate variable in str (if any) from %opts
+sub interpolate ($%) {
+ my ($str, %opts) = @_;
+
+ # Since we wish to leave undefined $var references in tact the following while
+ # loop would loop indefinitely if we don't change the variable. So we work
+ # with a copy of $str changing it always, but only changing the original $str
+ # for proper interpolations.
+ my $copyStr = $str;
+
+ while ($copyStr =~ /\$(\w+)/) {
+ my $var = $1;
+
+ if (exists $opts{$var}) {
+ $str =~ s/\$$var/$opts{$var}/;
+ $copyStr =~ s/\$$var/$opts{$var}/;
+ } elsif (exists $ENV{$var}) {
+ $str =~ s/\$$var/$ENV{$var}/;
+ $copyStr =~ s/\$$var/$ENV{$var}/;
+ } else {
+ $copyStr =~ s/\$$var//;
+ } # if
+ } # while
+
+ return $str;
+} # interpolate
+
+sub _processFile ($%) {
+ my ($configFile, %opts) = @_;
+
+ while (<$configFile>) {
+ chomp;
+
+ next if /^\s*[\#|\!]/; # Skip comments
+
+ if (/\s*(\w*)\s*:\s*(.*)\s*$/) {
+ my $key = $1;
+ my $value = $2;
+
+ # Strip trailing spaces
+ $value =~ s/\s+$//;
+
+ # Interpolate
+ $value = interpolate $value, %opts;
+
+ if ($opts{$key}) {
+ # If the key exists already then we have a case of multiple values for
+ # the same key. Since we support this we need to replace the scalar
+ # value with an array of values...
+ if (ref $opts{$key} eq "ARRAY") {
+ # It's already an array, just add to it!
+ push @{$opts{$key}}, $value;
+ } else {
+ # It's not an array so make it one
+ my @a;
+
+ push @a, $opts{$key};
+ push @a, $value;
+ $opts{$key} = \@a;
+ } # if
+ } else {
+ # It's a simple value
+ $opts{$key} = $value;
+ } # if
+ } # if
+ } # while
+
+ return %opts;
+} # _processFile
+
+sub GetConfig ($) {
+ my ($filename) = @_;
+
+=pod
+
+=head2 GetConfig ($conf)
+
+Reads $filename looking for .XDefaults style name/value pairs and
+returns a hash.
+
+Parameters:
+
+=begin html
+
+<blockquote>
+
+=end html
+
+=over
+
+=item $conf
+
+Name of configuration file
+
+=back
+
+=begin html
+
+</blockquote>
+
+=end html
+
+Returns:
+
+=begin html
+
+<blockquote>
+
+=end html
+
+=over
+
+=item Hash of name/value pairs
+
+=back
+
+=begin html
+
+</blockquote>
+
+=end html
+
+=cut
+
+ my %opts;
+
+ open my $configFile, '<', $filename
+ or carp "Unable to open config file $filename";
+
+ %opts = _processFile $configFile;
+
+ close $configFile;
+
+ return %opts;
+} # GetConfig
+
+1;
+
+=pod
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<File::Spec>
+
+=head1 INCOMPATABILITIES
+
+None yet...
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this module.
+
+Please report problems to Andrew DeFaria (Andrew@DeFaria.com).
+
+=head1 AUTHOR
+
+Andrew DeFaria (Andrew@DeFaria.com)
+
+=head1 LICENSE AND COPYRIGHT
+
+This Perl Module is freely available; you can redistribute it and/or
+modify it under the terms of the GNU General Public License as
+published by the Free Software Foundation; either version 2 of the
+License, or (at your option) any later version.
+
+This Perl Module is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License (L<http://www.gnu.org/copyleft/gpl.html>) for more
+details.
+
+You should have received a copy of the GNU General Public License
+along with this Perl Module; if not, write to the Free Software Foundation,
+Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+reserved.
+
+=cut
--- /dev/null
+=pod
+
+=head1 NAME $RCSfile: Logger.pm,v $
+
+Object oriented interface to handling logfiles
+
+=head1 VERSION
+
+=over
+
+=item Author:
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision:
+
+$Revision: 1.23 $
+
+=item Created:
+
+Fri Mar 12 10:17:44 PST 2004
+
+=item Modified:
+
+$Date: 2012/01/06 22:00:09 $
+
+=back
+
+=head1 SYNOPSIS
+
+Perl module for consistent creation and writing to logfiles
+
+ $log = Logger->new (
+ path => "/tmp"
+ timestamped => "yes",
+ append => "yes",
+ );
+
+ $log->msg ("This message might appear on STDOUT");
+ $log->log ("Stuff this message into the logfile");
+
+ if (!$log->logcmd ("ls /non-existant-dir")) {
+ $log->err ("Unable to proceed", 1);
+ } # if
+
+ $log->maillog (
+ to => "Andrew\@ClearSCM.com",
+ subject => "Logger test",
+ heading => "Results of Logging"
+ );
+
+=head1 DESCRIPTION
+
+Logger creates a log object that provides easy methods to log messages, errors,
+commands, etc. to log files. Logfiles can be created as being transient in that
+they will automatically disappear (unless you call the err method). You can
+capture the output of commands into log files and even have them autoamatically
+timestamped. Finally you can have logfiles automatically mailed.
+
+=head1 ROUTINES
+
+The following routines are exported:
+
+=cut
+
+package Logger;
+
+use strict;
+use warnings;
+
+use base 'Exporter';
+
+use FindBin;
+use File::Spec;
+use IO::Handle;
+use Cwd;
+
+use Display;
+use OSDep;
+use DateUtils;
+use Mail;
+use Utils;
+
+my ($error_color, $warning_color, $command_color, $highlight_color, $normal) = "";
+
+my $me;
+
+BEGIN {
+ # Extract relative path and basename from script name.
+ $me = $FindBin::Script;
+
+ # Remove .pl for Perl scripts that have that extension
+ $me =~ s/\.pl$//;
+} # BEGIN
+
+sub new (;%){
+ my ($class, %parms) = @_;
+
+=pod
+
+=head2 new (<parms>)
+
+Construct a new Logger object. The following OO style arguments are
+supported:
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item name:
+
+Name of the leaf portion of the log file. Default is the name of the
+script with ".log" appended to the logfile name. So if the calling
+script was called "getdb" the default log file would be called
+"getdb.log" (Default: Script name).
+
+=item path:
+
+Path to create the logfile in (Default: Current working directory)
+
+=item disposition:
+
+One of "temp" or "perm". Logfiles that are of disposition temp will be
+deleted when the process ends unless any calls have been made to the
+err method (Default: perm)
+
+=item timestamped:
+
+If set to 0 then no timestamps will be used. If set to 1 then all
+lines logged will be preceeded with a timestamp (Default: 0)
+
+=item append:
+
+If defined the logfile will be appended to (Default: Overwrite)
+
+=item extension
+
+If defined an alternate extension to use for the log file (e.g. log.html)
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Logger object
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my $cwd = cwd;
+
+ my $name = $parms{name} ? $parms{name} : $me;
+ my $path = $parms{path} ? $parms{path} : $cwd;
+ my $disposition = $parms{disposition} ? $parms{disposition} : 'perm';
+ my $timestamped = $parms{timestamped} ? $parms{timestamped} : 'FALSE';
+ my $append = $parms{append} ? '>>' : '>';
+ my $extension = $parms{extension} ? $parms{extension} : 'log';
+ my $logfile;
+
+ $name = "$name.$extension";
+
+ open $logfile, $append, "$path/$name"
+ or error "Unable to open logfile $path/$name - $!", 1;
+
+ # Set unbuffered output
+ $logfile->autoflush ();
+
+ set_verbose
+ if $ENV{VERBOSE};
+ set_debug
+ if $ENV{DEBUG};
+
+ return bless {
+ path => $path,
+ name => $name,
+ handle => $logfile,
+ timestamped => $parms {timestamped},
+ disposition => $disposition,
+ errors => 0,
+ warnings => 0,
+ }, $class; # bless
+} # new
+
+sub append ($) {
+ my ($self, $filename) = @_;
+
+=pod
+
+=head3 append ($filename)
+
+Appends $filename to the end of the current logfile
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $filename
+
+Filename to append to the logfile
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Nothing
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ open my $file, '<', $filename
+ or return 1;
+
+ while (<$file>) {
+ $self->log ($_);
+ } # while
+
+ close $file;
+
+ return;
+} # append
+
+sub name () {
+ my ($self) = @_;
+
+=pod
+
+=head3 name
+
+Returns the leaf portion of logfile name.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item None
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Leaf node of log file name
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{name};
+} # name
+
+sub fullname () {
+ my ($self) = @_;
+
+=pod
+
+=head3 fullname
+
+Returns the full pathname to the logfile
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item None
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Full pathname to the logfile
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return "$self->{path}/$self->{name}";
+} # fullname
+
+sub msg ($;$) {
+ my ($self, $msg, $nolinefeed) = @_;
+
+=pod
+
+=head3 msg ($msg, $nolinefeed)
+
+Similar to log except verbose (See Display.pm) is used to possibly
+additionally write the $msg to STDOUT.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $msg:
+
+Message to display
+
+=item $nolinefeed:
+
+If defined no linefeed is displayed at the end of the message.
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Nothing
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $self->log ($msg, $nolinefeed);
+
+ verbose $msg, undef, $nolinefeed;
+
+ return;
+} # msg
+
+sub disp ($;$) {
+ my ($self, $msg, $nolinefeed) = @_;
+
+=pod
+
+=head3 disp ($msg, $nolinefeed)
+
+Similar to log except display (See Display.pm) is used to write the $msg to
+STDOUT and to the log file.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $msg:
+
+Message to display
+
+=item $nolinefeed:
+
+If defined no linefeed is displayed at the end of the message.
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Nothing
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $self->log ($msg, $nolinefeed);
+
+ display $msg, undef, $nolinefeed;
+
+ return;
+} # disp
+
+sub incrementErr (;$) {
+ my ($self, $increment) = @_;
+
+=pod
+
+=head3 incrementErr ($msg, $errno)
+
+Increments the error count by $increment
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $increment
+
+Amount to increment (Default: 1)
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Nothing
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $increment ||= 1;
+
+ $self->{errors} += $increment;
+} # incrementErr
+
+sub err ($;$) {
+ my ($self, $msg, $errno) = @_;
+
+=pod
+
+=head3 err ($msg, $errno)
+
+Writes an error message to the log file. Error messages are prepended
+with "ERROR" and optionally "#$errno" (if $errno is specified),
+followed by the message. If $errno was specified then the string " -
+terminating" is appended to the message. Otherwise the number of
+errors in the log are incremented and used to determine the logfile's
+disposition at close time.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $msg:
+
+Message to display
+
+=item $errno:
+
+Error number to display (also causes termination).
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Nothing
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ display_error ($msg, $errno);
+
+ if ($errno) {
+ $msg = "ERROR #$errno: $msg - terminating";
+ } else {
+ $msg = "ERROR: $msg";
+ } # if
+
+ $self->log ($msg);
+
+ $self->incrementErr;
+
+ exit $errno if $errno;
+
+ return;
+} # err
+
+sub maillog (%) {
+ my ($self, %parms) = @_;
+
+=pod
+
+=head3 maillog (<parms>)
+
+Mails the current logfile. "Parms" are the same as the parameters
+described for Mail.pm.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item <See Mail.pm>
+
+Supports all parameters that Mail::mail supports.
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item None
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my $from = $parms{from};
+ my $to = $parms{to};
+ my $cc = $parms{cc};
+ my $subject = $parms{subject};
+ my $heading = $parms{heading};
+ my $footing = $parms{footing};
+ my $mode = $parms{mode};
+
+ $mode = "plain"
+ unless $mode;
+
+ my $log_filename = "$self->{path}/$self->{name}";
+
+ open my $logfile, '<', $log_filename
+ or error "Unable to open logfile $log_filename", 1;
+
+ if ($mode eq 'html') {
+ $heading .= '<b>Logfile:</b> '
+ . "$self->{path}/$self->{name}"
+ .'<hr><pre>';
+ $footing = '</pre><hr>'
+ . $footing;
+ } # if
+
+ mail (
+ from => $from,
+ to => $to,
+ cc => $cc,
+ subject => $subject,
+ mode => $mode,
+ heading => $heading,
+ footing => $footing,
+ data => $logfile
+ );
+
+ close $logfile
+ or error "Unable to close logfile $log_filename", 1;
+
+ return;
+} # maillog
+
+sub log {
+ my ($self, $msg, $nolinefeed) = @_;
+
+=pod
+
+=head3 log ($msg, $nolinefeed)
+
+Writes $msg to the log file. Note this is a "silent" log in that $msg
+is simply written to the logfile and not possibly also echoed to
+STDOUT (See the msg method).
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $msg:
+
+Message to write to log file
+
+=item $nolinefeed:
+
+If defined no linefeed is displayed at the end of the message.
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Nothing
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $msg = "$me: " . YMDHM . ": $msg" if $self->{timestamped};
+
+ display $msg, $self->{handle}, $nolinefeed;
+
+ return;
+} # log
+
+sub logcmd ($) {
+ my ($self, $cmd) = @_;
+
+=pod
+
+=head3 logcmd ($cmd)
+
+Execute the command in $cmd storing all output into the logfile
+
+=for html <blockquote>
+
+=over
+
+=item $cmd:
+
+The command $cmd is executed with the results logged to the logfile.
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Scalar representing the exit status of $cmd and an array of the commands output.
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ display "\$ $cmd", $self->{handle} if get_debug;
+
+ my $status = open my $output, '|', "$cmd 2>&1";
+
+ if (!$status) {
+ $self->{error}++;
+ return 1;
+ } # if
+
+ my @output;
+
+ while (<$output>) {
+ chomp;
+ push @output, $_;
+ display $_, $self->{handle};
+ display $_ if get_debug;
+ } # while
+
+ close $output
+ or error "Unable to close output ($!)", 1;
+
+ return ($?, @output);
+} # logcmd
+
+sub loglines () {
+ my ($self) = @_;
+
+=pod
+
+=head3 loglines
+
+Returns an array of lines from the current logfile.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item None
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Array of lines from the logfile
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return ReadFile "$self->{path}/$self->{name}";
+} # loglines
+
+sub warn ($;$) {
+ my ($self, $msg, $warnno) = @_;
+
+=pod
+
+=head3 warn ($msg, $warnno)
+
+Similar to error but logs the message as a warning. Increments the
+warnings count in the object thus also affecting its disposition at
+close time. Does not terminate the process if $warnno is specified.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $msg:
+
+Message to write to the logfile
+
+=item $warnno:
+
+Warning number to put in the warn message (if specified)
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Nothing
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ warning $msg, $warnno;
+
+ if ($warnno) {
+ $msg = "WARNING #$warnno: $msg";
+ } else {
+ $msg = "WARNING: $msg";
+ } # if
+
+ $self->log ($msg);
+ $self->{warnings}++;
+
+ return;
+} # warn
+
+sub errors () {
+ my ($self) = @_;
+
+=pod
+
+=head3 errors ()
+
+Returns the number of errors encountered
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item None
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $errors
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{errors};
+} # errors
+
+sub warnings () {
+ my ($self) = @_;
+
+=pod
+
+=head3 warnings ()
+
+Returns the number of warnings encountered
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item None
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $warnings
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{warnings};
+} # warnings
+
+sub DESTROY () {
+ my ($self) = @_;
+
+ close ($self->{handle});
+
+ if ($self->{disposition} eq 'temp') {
+ if ($self->{errors} == 0 and
+ $self->{warnings} == 0) {
+ unlink $self->fullname;
+ } # if
+ } # if
+
+ return;
+} # destroy
+
+1;
+
+=pod
+
+=head2 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug in this module is set.
+
+VERBOSE: If set then $verbose in this module is set.
+
+=head2 DEPENDENCIES
+
+=head3 Perl Modules
+
+L<File::Spec>
+
+L<IO::Handle>
+
+=head3 ClearSCM Perl Modules
+
+=for html <p><a href="/php/cvs_man.php?file=lib/DateUtils.pm">DateUtils</a></p>
+
+=for html <p><a href="/php/cvs_man.php?file=lib/Display.pm">Display</a></p>
+
+=for html <p><a href="/php/cvs_man.php?file=lib/Mail.pm">Mail</a></p>
+
+=for html <p><a href="/php/cvs_man.php?file=lib/OSDep.pm">OSDep</a></p>
+
+=for html <p><a href="/php/cvs_man.php?file=lib/Utils.pm">Utils</a></p>
+
+=head2 INCOMPATABILITIES
+
+None yet...
+
+=head2 BUGS AND LIMITATIONS
+
+There are no known bugs in this module.
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head2 LICENSE AND COPYRIGHT
+
+This Perl Module is freely available; you can redistribute it and/or
+modify it under the terms of the GNU General Public License as
+published by the Free Software Foundation; either version 2 of the
+License, or (at your option) any later version.
+
+This Perl Module is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License (L<http://www.gnu.org/copyleft/gpl.html>) for more
+details.
+
+You should have received a copy of the GNU General Public License
+along with this Perl Module; if not, write to the Free Software Foundation,
+Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+reserved.
+
+=cut
--- /dev/null
+=pod
+
+=head1 NAME $RCSfile: Machines.pm,v $
+
+Abstraction of machines.
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.4 $
+
+=item Created
+
+Tue Jan 8 17:24:16 MST 2008
+
+=item Modified
+
+$Date: 2011/11/16 19:46:13 $
+
+=back
+
+=head1 SYNOPSIS
+
+This module handles the details of providing information about
+machines while obscuring the mechanism for storing such information.
+
+ my $machines = Machines->new;
+
+ foreach ($machine->all) {
+ my %machine = %{$_};
+ display "Machine: $machine{name}";
+ disp.ay "Owner: $machine{owner}"
+ } # if
+
+=head1 DESCRIPTION
+
+This module provides information about machines
+
+=head1 ROUTINES
+
+The following routines are exported:
+
+=cut
+
+package Machines;
+
+use strict;
+use warnings;
+
+use Display;
+use Utils;
+
+use base 'Exporter';
+
+our @EXPORT = qw (
+ all
+ new
+);
+
+sub new {
+ my ($class, %parms) = @_;
+
+=pod
+
+=head2 new (<parms>)
+
+Construct a new Machines object. The following OO style arguments are
+supported:
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item file:
+
+Name of an alternate file from which to read machine information. This
+is intended as a quick alternative.
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Machines object
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my $file = $parms{file} ? $parms{file} : "$FindBin::Bin/../etc/machines";
+
+ error "Unable to find $file", 1 if ! -f $file;
+
+ my %machines;
+
+ foreach (ReadFile $file) {
+ my @parts = split;
+
+ # Skip commented out or blank lines
+ next if $parts[0] =~ /^#/ or $parts[0] =~ /^$/;
+
+ $machines{$parts[0]} = $parts[1];
+ } # foreach
+
+ bless {
+ file => $parms {file},
+ machines => \%machines,
+ }, $class; # bless
+
+ return $class;
+} # new
+
+sub all () {
+ my ($self) = @_;
+
+=pod
+
+=head3 all ()
+
+Returns all known machines as an array of hashes
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=begin html
+
+<blockquote>
+
+=end html
+
+=over
+
+=item Array of machine hash records
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return %{$self->{machines}};
+} # display
+
+1;
+
+=pod
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+MACHINES: If set then points to a flat file containing machine
+names. Note this is providied as a way to quickly use an alternate
+"machine database". As such only minimal information is support.
+
+=head1 DEPENDENCIES
+
+ Display
+ Rexec
+
+=head1 INCOMPATABILITIES
+
+None yet...
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this module.
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+This Perl Module is freely available; you can redistribute it and/or
+modify it under the terms of the GNU General Public License as
+published by the Free Software Foundation; either version 2 of the
+License, or (at your option) any later version.
+
+This Perl Module is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License (L<http://www.gnu.org/copyleft/gpl.html>) for more
+details.
+
+You should have received a copy of the GNU General Public License
+along with this Perl Module; if not, write to the Free Software Foundation,
+Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+reserved.
+
+=cut
--- /dev/null
+=pod
+
+=head1 NAME $RCSfile: Mail.pm,v $
+
+A simplified approach to sending email
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.34 $
+
+=item Created
+
+Thu Jan 5 15:15:29 PST 2006
+
+=item Modified
+
+$Date: 2012/09/25 01:34:10 $
+
+=back
+
+=head1 SYNOPSIS
+
+Conveniently send email.
+
+ my $msg = "<h1>The Daily News</h1><p>Today in the news...</p>";
+
+ mail (
+ to => "somebody\@somewhere.com",
+ cc => "sombody_else\@somewhere.com",
+ subject => "Today's News",
+ mode => "html",
+ data => $msg,
+ );
+
+ open STATUS_REPORT, "status.html";
+
+ mail (
+ to => "boss\@mycompany.com",
+ bcc => "mysecret\@mailbox.com",
+ subject => "Weekly Status Report",
+ data => STATUS_REPORT,
+ footing => "Another day - Another dollar!"
+ );
+
+ close STATUS_REPORT;
+
+=head1 DESCRIPTION
+
+Sending email from Perl scripts is another one of those things that is
+often reinvented over and over. Well... This is yet another
+reinvention I guess. The goal here is to allow for a simplifed
+approach to sending email while still allowing MIME or rich text email
+to be sent.
+
+Additionally a multipart (plain text and HTML'ized) email will be send
+if mode is set to html. Finally, if attempting to send HTML mail, if
+we cannot find the appropriate dependent modules we'll fall back to
+plain text only.
+
+=head1 ROUTINES
+
+The following routines are exported:
+
+=cut
+
+package Mail;
+
+use strict;
+use warnings;
+
+use base 'Exporter';
+
+use FindBin;
+use File::Basename;
+use Net::SMTP;
+
+use Display;
+use GetConfig;
+
+our @EXPORT = qw (
+ mail
+);
+
+my ($err, %config);
+
+my $mail_conf = dirname (__FILE__) . '/../etc/mail.conf';
+
+if (-r $mail_conf) {
+ %config = GetConfig $mail_conf;
+
+ $config{SMTPHOST} = $ENV{SMTPHOST} || $config{SMTPHOST};
+
+ $err = "SMTPHOST not defined in $mail_conf nor in the environment variable SMTPHOST"
+ unless $config{SMTPHOST};
+
+ unless ($err) {
+ $config{SMTPFROM} = $ENV{SMTPFROM} || $config{SMTPFROM};
+
+ $err = "SMTPFROM not defined in $mail_conf nor in the environment variable SMTPFROM"
+ unless $config{SMTPFROM};
+ } # unless
+} else {
+ $err = "Unable to read mail config file $mail_conf";
+} # if
+
+sub mail {
+ my (%parms) = @_;
+
+=pod
+
+=head2 mail (<parms>)
+
+Send email. The following OO style arguments are supported:
+
+=begin html
+
+<blockquote>
+
+=end html
+
+=over
+
+=item from
+
+The from email address. If not specified then defaults to $ENV{SMTPFROM}.
+
+=item to
+
+Comma separated list of email addresses to set the mail to. At least
+one address must be specified.
+
+=item cc
+
+Comma separated list of email addresses to cc the mail to.
+
+=item bcc
+
+Comma separated list of email addresses to bcc the mail to.
+
+=item subject
+
+Subject line for email (Default: "(no subject)")
+
+=item mode
+
+Mode to send the email as. Values can be "plain", "text/plain",
+"html", "text/html".
+
+=item data
+
+Either a scalar that contains the message or a filehandle to an open
+file which contains the message. Can contain HTML if mode = HTML.
+
+=item heading
+
+Text to be included at the beginning of the email message. Can
+contain HTML if mode = HTML.
+
+=item footing
+
+Text to be included at the end fo the email message. Can contain HTML
+if mode = HTML.
+
+=back
+
+=begin html
+
+</blockquote>
+
+=end html
+
+Returns:
+
+=begin html
+
+<blockquote>
+
+=end html
+
+=over
+
+=item Nothing
+
+=back
+
+=begin html
+
+</blockquote>
+
+=end html
+
+=cut
+
+ # If from isn't specified we'll use a default
+ my $from = defined $parms{from} ? $parms{from} : $config{SMTPFROM};
+
+ error $err, 1 if $err;
+
+ my $me = "Mail::mail";
+
+ # Make arrays for to, cc and bcc
+ my (@to, @cc, @bcc);
+ @to = split /, */, $parms{to};
+ @cc = split /, */, $parms{cc} if defined $parms{cc};
+ @bcc = split /, */, $parms{bcc} if defined $parms{bcc};
+
+ error "$me: You must specify \"to\"" if scalar @to == 0;
+ warning "$me: You should specify \"subject\"" if !defined $parms{subject};
+
+ my $subject = defined $parms{subject} ? $parms{subject} : "(no subject)";
+
+ my $mode;
+
+ if (!defined $parms{mode}) {
+ $mode = "text/plain";
+ } elsif ($parms{mode} eq "plain" or $parms{mode} eq "text/plain") {
+ $mode = "text/plain";
+ } elsif ($parms{mode} eq "html") {
+ $mode = "text/html";
+ } elsif ($parms{mode} eq "html") {
+ $mode = "text/html";
+ # Make sure we can get our modules...
+ eval { require MIME::Entity }
+ or error "Unable to find MIME::Entity module", 1;
+ eval { require HTML::Parser }
+ or error "Unable to find HTML::Parser module", 1;
+ eval { require HTML::FormatText }
+ or error "Unable to find HTML::FormatText module", 1;
+ eval { require HTML::TreeBuilder }
+ or error "Unable to find HTML::TreeBuilder module", 1;
+ } else {
+ error "Mode, ${parms{mode}}, is invalid - should be plain or html", 1;
+ } # if
+
+ # Connect to server
+ my $smtp = Net::SMTP->new ($config{SMTPHOST})
+ or error "Unable to connect to mail server: $config{SMTPHOST}", 1;
+
+ # Address the mail
+ $smtp->mail ($from);
+
+ # Who are we sending to...
+ $smtp->to ($_, {SkipBad => 1}) foreach (@to);
+ $smtp->cc ($_, {SkipBad => 1}) foreach (@cc);
+ $smtp->bcc ($_, {SkipBad => 1}) foreach (@bcc);
+
+ # Now write the headers
+ $smtp->data;
+ $smtp->datasend ("From: $from\n");
+ $smtp->datasend ("To: $_\n") foreach (@to);
+ $smtp->datasend ("Cc: $_\n") foreach (@cc);
+ $smtp->datasend ("Subject: $subject\n");
+ $smtp->datasend ("Content-Type: $mode\n");
+ $smtp->datasend ("\n");
+
+ # If heading is specified then the user wants this stuff before the main
+ # message
+ my $msgdata = $parms{heading};
+ chomp $msgdata if $msgdata;
+
+ # If $parms{data} is a GLOB we'll assume it's a FILE reference.
+ if (ref ($parms{data}) eq "GLOB") {
+ my @lines;
+ my $datafile = $parms{data};
+
+ # Just because it's a file reference doesn't mean that it's a valid file
+ # reference!
+ unless (eval { @lines = <$datafile> }) {
+ error "$me: File passed in to mail is invalid - $!", 1
+ } # unless
+
+ $msgdata .= join "", @lines;
+ } else {
+ $msgdata .= $parms{data};
+ } # if
+
+ # If footing is specified then the user wants this stuff after the main
+ # message
+ $msgdata .= $parms{footing} if defined $parms{footing};
+
+ # if the user requested html mode then convert the message to HTML
+ if ($mode eq "multipart") {
+ # Create multipart container
+ my $container = MIME::Entity->build (
+ Type => "multipart/alternative",
+ From => $from,
+ Subject => $subject
+ );
+
+ # Create a textual version of the HTML
+ my $html = HTML::TreeBuilder->new;
+ $html->parse ($msgdata);
+ $html->eof;
+ my $formatter = HTML::FormatText->new (
+ leftmargin => 0,
+ rightmargin => 80
+ );
+ my $plain_text = $formatter->format ($html);
+
+ # Create ASCII attachment first
+ $container->attach (
+ Type => "text/plain",
+ Encoding => "quoted-printable",
+ Data => $plain_text,
+ );
+
+ # Create HTML attachment
+ $container->attach (
+ Type => "text/html",
+ Encoding => "quoted-printable",
+ Data => $msgdata,
+ );
+
+ $container->smtpsend (Host => $smtp);
+ } else {
+ # Plain text here
+ $smtp->datasend ($msgdata);
+ } # if
+
+ # All done
+ $smtp->dataend;
+ $smtp->quit;
+
+ return;
+} # mail
+
+1;
+
+=pod
+
+=head2 CONFIGURATION AND ENVIRONMENT
+
+SMTPHOST: Set to the appropriate mail server
+
+SMTPFROM: Set to a from address to be used as a default
+
+=head2 DEPENDENCIES
+
+=head3 Perl Modules
+
+L<Net::SMTP>
+
+L<File::Basename>
+
+=head3 CPAN Modules
+
+(Optionally - i.e. if html email is requested:)
+
+=for html <p><a href="http://search.cpan.org/search?query=MIME::Entity">MIME::Entity</a>
+
+=for html <p><a href="http://search.cpan.org/search?query=HTML::Parser">HTML::Parser</a>
+
+=for html <p><a href="http://search.cpan.org/search?query=HTML::FormatText">HTML::FormatText</a>
+
+=for html <p><a href="http://search.cpan.org/search?query=HTML::TreeBuilder">HTML::TreeBuilder</a>
+
+=head3 ClearSCM Perl Modules
+
+=for html <p><a href="/php/cvs_man.php?file=lib/Display.pm">Display</a></p>
+
+=for html <p><a href="/php/cvs_man.php?file=lib/GetConfig.pm">GetConfig</a></p>
+
+=head2 INCOMPATABILITIES
+
+None yet...
+
+=head2 BUGS AND LIMITATIONS
+
+There are no known bugs in this module.
+
+Please report problems to Andrew DeFaria >Andrew@ClearSCM.com>.
+
+=head2 LICENSE AND COPYRIGHT
+
+This Perl Module is freely available; you can redistribute it and/or
+modify it under the terms of the GNU General Public License as
+published by the Free Software Foundation; either version 2 of the
+License, or (at your option) any later version.
+
+This Perl Module is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License (L<http://www.gnu.org/copyleft/gpl.html>) for more
+details.
+
+You should have received a copy of the GNU General Public License
+along with this Perl Module; if not, write to the Free Software Foundation,
+Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+reserved.
+
+=cut
--- /dev/null
+=pod
+
+=head1 NAME $RCSfile: OSDep.pm,v $
+
+Isolate OS dependencies
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.12 $
+
+=item Created
+
+Tue Jan 3 11:36:10 PST 2006
+
+=item Modified
+
+$Date: 2011/11/16 19:46:13 $
+
+=back
+
+=head1 SYNOPSIS
+
+This module seeks to isolate OS dependences by confining them to this
+module as well as provide convienent references and mechanisms for
+doing things that are different on different OSes.
+
+ print "Running on $ARCH\n";
+ `$cmd > $NULL 2>&1`;
+ my $filename = $app_base . $SEPARATOR . "datafile.txt";
+
+=head1 DESCRIPTION
+
+This module exports several variables that are useful to isolate OS
+dependencies. For example, $ARCH is set to "windows", "cygwin" or the
+value of $^O depending on which OS the script is running. This allows
+you to write code that is dependant on which OS you are running
+on. Similarly, $NULL is set to the string "NUL" when running on
+Windows otherwise it is set to "/dev/null" (Under Cygwin /dev/null is
+appropriate). This way if you wish to say redirect output to "null"
+you can use $NULL.
+
+There is currently only one subroutine exported, Chrooted, which
+returns $TRUE if you are operating in a chrooted environment, $FALSE
+otherwise;
+
+=head1 ROUTINES
+
+The following routines are exported:
+
+=cut
+
+package OSDep;
+
+use strict;
+use warnings;
+
+use base 'Exporter';
+
+our $ARCH = $^O =~ /MSWin/
+ ? 'windows'
+ : $^O =~ /cygwin/
+ ? "cygwin"
+ : $^O;
+our $NULL = $^O =~ /MSWin/ ? 'NUL' : '/dev/null';
+our $SEPARATOR = $^O =~ /MSWin/ ? '\\' : '/';
+our $TRUE = 1;
+our $FALSE = 0;
+our $ROOT = $^O =~ /MSWin/ ? $ENV {SYSTEMDRIVE} . $SEPARATOR : "/";
+
+our @EXPORT = qw (
+ $ARCH
+ $FALSE
+ $NULL
+ $SEPARATOR
+ $TRUE
+ Chrooted
+);
+
+sub Chrooted () {
+
+=pod
+
+=head2 Chrooted ()
+
+Returns $TRUE if you are operating under a chrooted environment,
+$FALSE otherwise.
+
+Parameters:
+
+=begin html
+
+<blockquote>
+
+=end html
+
+=over
+
+=item None
+
+=back
+
+=begin html
+
+</blockquote>
+
+=end html
+
+Returns:
+
+=begin html
+
+<blockquote>
+
+=end html
+
+=over
+
+=item Boolean
+
+=back
+
+=begin html
+
+</blockquote>
+
+=end html
+
+=cut
+
+ if ($ARCH eq "windows" or $ARCH eq "cygwin") {
+ # Not sure how this relates to Windows/Cygwin environment so just
+ # return false
+ return $FALSE;
+ } else {
+ return ((stat $ROOT) [1] != 2);
+ } # if
+} # Chrooted
+
+1;
+
+=pod
+
+=head1 VARIABLES
+
+=over
+
+=item $ARCH
+
+Set to either "windows", "cygwin" or $^O.
+
+=item $NULL
+
+Set to "NUL" for Windows, "/dev/null" otherwise.
+
+=item $SEPARATOR}
+
+Set to "\" for Windows, "/" otherwise.
+
+=item $TRUE;
+
+Convenient boolean variable set to 1 (Cause I always forget if 1 or 0
+is true)
+
+=item $FALSE
+
+Convenient boolean variable set to 0 (Cause I always forget if 1 or 0
+is false)
+
+=item $ROOT
+
+Set to SYSTEMDRIVE for Windows, "/" otherwise
+
+=back
+
+=head1 DEPENDENCIES
+
+None
+
+=head1 INCOMPATABILITIES
+
+None yet...
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this module.
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+This Perl Module is freely available; you can redistribute it and/or
+modify it under the terms of the GNU General Public License as
+published by the Free Software Foundation; either version 2 of the
+License, or (at your option) any later version.
+
+This Perl Module is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License (L<http://www.gnu.org/copyleft/gpl.html>) for more
+details.
+
+You should have received a copy of the GNU General Public License
+along with this Perl Module; if not, write to the Free Software Foundation,
+Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+reserved.
+
+=cut
--- /dev/null
+=pod
+
+=head1 NAME $RCSfile: Rexec.pm,v $
+
+Execute commands remotely and returning the output and status of the
+remotely executed command.
+
+=head1 VERSION
+
+=over
+
+=item Author:
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision:
+
+$Revision: 1.21 $
+
+=item Created:
+
+Mon Oct 9 18:28:28 CDT 2006
+
+=item Modified:
+
+$Date: 2012/04/07 00:39:48 $
+
+=back
+
+=head1 SYNOPSIS
+
+ use Rexec;
+
+ my $status;
+ my $cmd;
+ my @lines;
+
+ my $remote = new Rexec (host => $host);
+
+ if ($remote) {
+ print "Connected using " . $remote->{protocol} . " protocol\n";
+
+ $cmd = "ls /tmp";
+ @lines = $remote->execute ($cmd);
+ $status = $remote->status;
+ print "$cmd status: $status\n";
+ $remote->print_lines;
+
+ print "$_\n" foreach ($remote->execute ("cat /etc/passwd"));
+ } else {
+ print "Unable to connect to $username\@$host\n";
+ } # if
+
+=head1 DESCRIPTION
+
+This module provides an object oriented interface to executing remote
+commands on Linux/Unix system (or potentially well configured Windows
+machines with Cygwin installed). Upon object creation a connection is
+attempted to the specified host in a cascaded fashion. First ssh is
+attempted, then rsh/rlogin and finally telnet. This clearly favors
+secure methods over those less secure ones. If username or password is
+prompted for, and if they are supplied, then they are used, otherwise
+the attempted connection is considered failed.
+
+Once connected the caller can use the exec method to execute commands
+on the remote host. Upon object destruction the connection is
+shutdown. Output from the remotely executed command is returned
+through the exec method and also avaiable view the lines
+method. Remote status is available via the status method. This means
+you can now more reliably obtain the status of the command executed
+remotely instead of just the status of the ssh/rsh command itself.
+
+Note: Currently no attempt has been made to differentiate output
+written to stdout and stderr.
+
+As Expect is used to drive the remote session particular attention
+should be defining a regex to locate the prompt. The standard prompt
+regex (if not specified by the caller at object creation) is qr'[#>:$]
+$'. This covers most default and common prompts.
+
+=head1 Handling Timeouts
+
+The tricky thing when dealing with remote execution is attempting to
+determine if the remote machine has finished, stopped responding or
+otherwise crashed. It's more of an art than a science! The best one
+can do it send the command along and wait for a response. But how long
+to wait is the question. If your wait is too short then you run the
+risk of timing out before the remote command is finished. If you wait
+too long then you can be possibly waiting for something that will not
+be happening because the remote machine is either down or did not
+behave in a manner that you expected it to.
+
+To a large extent this module attempts to mitigate these issues on the
+principal that remote command execution is pretty well known. You log
+in and get a prompt. Issue a command and get another prompt. If the
+prompts are well known and easily determinable things go
+smoothly. However what happens if you execute a command remotely that
+will take 30 minutes to finish?
+
+This module has two timeout values. The first is login timeout. It's
+assumed that logins should happen fairly quickly. The default timeout
+for logins is 5 seconds.
+
+Command timeouts are set by default to 30 seconds. Most commands will
+finish before then. If you expect a command to take much longer then
+you can set an alternate timeout period.
+
+You can achieve longer timeouts in several ways. To give a longer
+login timeout specify your timeout to the new call. To give a longer
+exec timeout either pass a longer timeout to exec or set it view
+setTimeout. The current exec timeout is returned by getTimeout.
+
+=head1 METHODS
+
+The following routines are exported:
+
+=cut
+
+package Rexec;
+
+use strict;
+use warnings;
+
+use base 'Exporter';
+
+use Carp;
+use Expect;
+
+our $VERSION = '1.0';
+
+# This is the "normal" definition of a prompt. However what's normal?
+# For example, my prompt it typically the machine name followed by a
+# colon. But even that appears in error messages such as <host>: not
+# found and will be mistaken for a prompt. No real good way to handle
+# this so we define a standard prompt here and allow the caller to
+# override that. But overriding it is tricky and left as an exercise
+# to the caller.
+
+# Here we have a number of the common prompt characters [#>:%$]
+# followed by a space and end of line.
+our $DEFAULT_PROMPT = qr'[#>:%$] $';
+
+my $default_login_timeout = 5;
+my $default_exec_timeout = 30;
+
+my $debug = $ENV{DEBUG} || 0;
+
+our @EXPORT = qw (
+ exec
+ host
+ lines
+ login
+ logout
+ new
+ print_lines
+ status
+);
+
+my @lines;
+
+sub ssh {
+ my ($self) = @_;
+
+ my ($logged_in, $timedout, $password_attempts) = 0;
+
+ $self->{protocol} = 'ssh';
+
+ my $user = $self->{username} ? "$self->{username}\@" : '';
+
+ my $remote = Expect->new ("ssh $self->{opts} $user$self->{host}");
+
+ return if !$remote;
+
+ $remote->log_user ($debug);
+
+ $remote->expect (
+ $self->{timeout},
+
+ # If password is prompted for, and if one has been specified, then
+ # use it
+ [ qr "[P|p]assword: $",
+ sub {
+ # If we already supplied the password then it must not have
+ # worked so this protocol is no good.
+ return if $password_attempts;
+
+ my $exp = shift;
+
+ # If we're being prompted for password and there is no
+ # password to supply then there is nothing much we can do but
+ # return undef since we can't get in with this protocol
+ return if !$self->{password};
+
+ $exp->send ("$self->{password}\n") if $self->{password};
+ $password_attempts++;
+
+ exp_continue;
+ }
+ ],
+
+ # Discard lines that begin with "ssh:" (like "ssh: <host>: not
+ # found")
+ [ qr'\nssh: ',
+ sub {
+ return;
+ }
+ ],
+
+ # If we find a prompt then everything's good
+ [ $self->{prompt},
+ sub {
+ $logged_in = 1;
+ }
+ ],
+
+ # Of course we may time out...
+ [ timeout =>
+ sub {
+ $timedout = 1;
+ }
+ ],
+ );
+
+ if ($logged_in) {
+ return $remote;
+ } elsif ($timedout) {
+ carp "WARNING: $self->{host} is not responding to $self->{protocol} protocol";
+ undef $remote;
+ return;
+ } else {
+ carp "WARNING: Unable to connect to $self->{host} using $self->{protocol} protocol";
+ return;
+ } # if
+} # ssh
+
+sub rlogin {
+ my ($self) = @_;
+
+ my ($logged_in, $timedout, $password_attempts) = 0;
+
+ $self->{protocol} = "rlogin";
+
+ my $user = $self->{username} ? "-l $self->{username}" : "";
+
+ my $remote = Expect->new ("rsh $user $self->{host}");
+
+ return if !$remote;
+
+ $remote->log_user ($debug);
+
+ $remote->expect (
+ $self->{timeout},
+
+ # If password is prompted for, and if one has been specified, then
+ # use it
+ [ qr "[P|p]assword: $",
+ sub {
+ # If we already supplied the password then it must not have
+ # worked so this protocol is no good.
+ return if $password_attempts;
+
+ my $exp = shift;
+
+ # If we're being prompted for password and there is no
+ # password to supply then there is nothing much we can do but
+ # return undef since we can't get in with this protocol
+ return if !$self->{password};
+
+ $exp->send ("$self->{password}\n");
+ $password_attempts++;
+
+ exp_continue;
+ }
+ ],
+
+ # HACK! rlogin may return "<host>: unknown host" which clashes
+ # with some prompts (OK it clashes with my prompt...)
+ [ ": unknown host",
+ sub {
+ return;
+ }
+ ],
+
+ # If we find a prompt then everything's good
+ [ $self->{prompt},
+ sub {
+ $logged_in = 1;
+ }
+ ],
+
+ # Of course we may time out...
+ [ timeout =>
+ sub {
+ $timedout = 1;
+ }
+ ],
+ );
+
+ if ($logged_in) {
+ return $remote;
+ } elsif ($timedout) {
+ carp "WARNING: $self->{host} is not responding to $self->{protocol} protocol";
+ undef $remote;
+ return;
+ } else {
+ carp "WARNING: Unable to connect to $self->{host} using $self->{protocol} protocol";
+ return;
+ } # if
+} # rlogin
+
+sub telnet {
+ my ($self) = @_;
+
+ my ($logged_in, $timedout, $password_attempts) = 0;
+
+ $self->{protocol} = "telnet";
+
+ my $remote = Expect->new ("telnet $self->{host}");
+
+ return if !$remote;
+
+ $remote->log_user ($debug);
+
+ $remote->expect (
+ $self->{timeout},
+
+ # If login is prompted for, and if what has been specified, then
+ # use it
+ [ qr "login: $",
+ sub {
+ my $exp = shift;
+
+ # If we're being prompted for username and there is no
+ # username to supply then there is nothing much we can do but
+ # return undef since we can't get in with this protocol
+ return if !$self->{username};
+
+ $exp->send ("$self->{username}\n");
+ exp_continue;
+ }
+ ],
+
+ # If password is prompted for, and if one has been specified, then
+ # use it
+ [ qr "[P|p]assword: $",
+ sub {
+ # If we already supplied the password then it must not have
+ # worked so this protocol is no good.
+ return if $password_attempts;
+
+ my $exp = shift;
+
+ # If we're being prompted for password and there is no
+ # password to supply then there is nothing much we can do but
+ # return undef since we can't get in with this protocol
+ return if !$self->{password};
+
+ $exp->send ("$self->{password}\n");
+ $password_attempts++;
+
+ exp_continue;
+ }
+ ],
+
+ # HACK! rlogin may return "<host>: Unknown host" which clashes
+ # with some prompts (OK it clashes with my prompt...)
+ [ ": Unknown host",
+ sub {
+ return;
+ }
+ ],
+
+ # If we find a prompt then everything's good
+ [ $self->{prompt},
+ sub {
+ $logged_in = 1;
+ }
+ ],
+
+ # Of course we may time out...
+ [ timeout =>
+ sub {
+ $timedout = 1;
+ }
+ ],
+ );
+
+ if ($logged_in) {
+ return $remote;
+ } elsif ($timedout) {
+ carp "WARNING: $self->{host} is not responding to $self->{protocol} protocol";
+ undef $remote;
+ return;
+ } else {
+ carp "WARNING: Unable to connect to $self->{host} using $self->{protocol} protocol";
+ return;
+ } # if
+} # telnet
+
+sub login () {
+ my ($self) = @_;
+
+=pod
+
+=head2 login
+
+Performs a login on the remote host. Normally this is done during
+construction but this method allows you to login, say again, as maybe
+another user...
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item None
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Nothing
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ # Close any prior opened sessions
+ $self->logoff if ($self->{handle});
+
+ my $remote;
+
+ if ($self->{protocol}) {
+ if ($self->{protocol} eq "ssh") {
+ return $self->ssh;
+ } elsif ($self->{protocol} eq "rsh" or $self->{protocol} eq "rlogin") {
+ return $self->rlogin;
+ } elsif ($self->{protocol} eq "telnet") {
+ return $self->telnet;
+ } else {
+ croak "ERROR: Invalid protocol $self->{protocol} specified", 1;
+ } # if
+ } else {
+ return $remote if $remote = $self->ssh;
+ return $remote if $remote = $self->rlogin;
+ return $self->telnet;
+ } # if
+
+ return;
+} # login
+
+sub logoff {
+ my ($self) = @_;
+
+=pod
+
+=head3 logoff
+
+Performs a logout on the remote host. Normally handled in the
+destructor but you could call logout to logout if you wish.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item None
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Nothing
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $self->{handle}->soft_close;
+
+ undef $self->{handle};
+ undef $self->{status};
+ undef $self->{lines};
+
+ return;
+} # logoff
+
+sub new {
+ my ($class) = shift;
+
+=pod
+
+=head3 new (<parms>)
+
+This method instantiates a new Rexec object. Currently only hash style
+parameter passing is supported.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item host => <host>:
+
+Specifies the host to connect to. Default: localhost
+
+=item username => <username>
+
+Specifies the username to use if prompted. Default: No username specified.
+
+=item password => <password>
+
+Specifies the password to use if prompted. Default: No password
+specified. Note passwords must be in cleartext at this
+time. Specifying them makes you insecure!
+
+=item prompt => <prompt regex>
+
+Specifies a regex describing how to identify a prompt. Default: qr'[#>:$] $'
+
+=item protocol => <ssh|rsh|rlogin|telnet>
+
+Specifies the protocol to use when connecting. Default: Try them all
+starting with ssh.
+
+=item opts => <options>
+
+Additional options for protocol (e.g. -X for ssh and X forwarding)
+
+=item verbose => <0|1>
+
+If true then status messages are echoed to stdout. Default: 0.
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Rexec object
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my %parms = @_;
+
+ my $self = {};
+
+ $self->{host} = $parms{host} ? $parms{host} : 'localhost';
+ $self->{username} = $parms{username};
+ $self->{password} = $parms{password};
+ $self->{prompt} = $parms{prompt} ? $parms{prompt} : $DEFAULT_PROMPT;
+ $self->{protocol} = $parms{protocol};
+ $self->{verbose} = $parms{verbose};
+ $self->{shellstyle} = $parms{shellstyle} ? $parms{shellstyle} : 'sh';
+ $self->{opts} = $parms{opts} ? $parms{opts} : '';
+ $self->{timeout} = $parms{timeout} ? $parms{timeout} : $default_login_timeout;
+
+ if ($self->{shellstyle} ne 'sh' and $self->{shellstyle} ne 'csh') {
+ croak 'ERROR: Unknown shell style specified. Must be one of "sh" or "csh"', 1;
+ } # if
+
+ bless ($self, $class);
+
+ # now login...
+ $self->{handle} = $self->login;
+
+ # Set timeout to $default_exec_timeout
+ $self->{timeout} = $default_exec_timeout;
+
+ return $self->{handle} ? $self : undef;
+} # new
+
+sub execute ($$) {
+ my ($self, $cmd, $timeout) = @_;
+
+=pod
+
+=head3 exec ($cmd, $timeout)
+
+This method executes a command on the remote host returning an array
+of lines that the command produced, if any. Status of the command is
+stored in the object and accessible via the status method.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $cmd:
+
+Command to execute remotely
+
+=item $timeout
+
+Set timeout for this execution. If timeout is 0 then wait forever. If
+you wish to interrupt this then set up a signal handler.
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item @lines
+
+An array of lines from STDOUT of the command. If STDERR is also wanted
+then add STDERR redirection to $cmd. Exit status is not returned by
+retained in the object. Use status method to retrieve it.
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ # If timeout is specified for this exec then use it - otherwise
+ # use the object's defined timeout.
+ $timeout = $timeout ? $timeout : $self->{timeout};
+
+ # If timeout is set to 0 then the user wants an indefinite
+ # timeout. But Expect wants it to be undefined. So undef it if
+ # it's 0. Note this means we do not support Expect's "check it
+ # only one time" option.
+ undef $timeout if $timeout == 0;
+
+ # If timeout is < 0 then the user wants to run the command in the
+ # background and return. We still need to wait as we still may
+ # timeout so change $timeout to the $default_exec_timeout in this
+ # case and add a "&" to the command if it's not already there.
+ # because the user has added a & to the command to run it in the
+ if ($timeout && $timeout < 0) {
+ $timeout = $default_exec_timeout;
+ $cmd .= "&" if $cmd !~ /&$/;
+ } # if
+
+ # Set status to -2 indicating nothing happened! We should never
+ # return -2 (unless a command manages to set $? to -2!)
+ $self->{status} = -2;
+
+ # Empty lines of any previous command output
+ @lines = ();
+
+ # Hopefully we will not see the following in the output string
+ my $errno_str = "ReXeCerRoNO=";
+ my $start_str = "StaRT";
+
+ my $compound_cmd;
+
+ # If cmd ends in a & then it makes no sense to compose a compound
+ # command. The original command will be in the background and thus
+ # we should not attempt to get a status - there will be none.
+ if ($cmd !~ /&$/) {
+ $compound_cmd = "echo $start_str; $cmd; echo $errno_str";
+ $compound_cmd .= $self->{shellstyle} eq "sh" ? "\$?" : "\$status";
+ } else {
+ $compound_cmd = $cmd;
+ } # if
+
+ $self->{handle}->send ("$compound_cmd\n");
+
+ $self->{handle}->expect (
+ $timeout,
+
+ [ timeout =>
+ sub {
+ $self->{status} = -1;
+ }
+ ],
+
+ [ qr "\n$start_str",
+ sub {
+ exp_continue;
+ }
+ ],
+
+ [ qr "\n$errno_str",
+ sub {
+ my ($exp) = @_;
+
+ my $before = $exp->before;
+ my $after = $exp->after;
+
+ if ($after =~ /(\d+)/) {
+ $self->{status} = $1;
+ } # if
+
+ my @output = split /\n/, $before;
+
+ chomp @output;
+ chop @output if $output[0] =~ /\r$/;
+
+ foreach (@output) {
+ next if /^$/;
+ last if /$errno_str=/;
+
+ push @lines, $_;
+ } # foreach
+
+ exp_continue;
+ }
+ ],
+
+ [ $self->{prompt},
+ sub {
+ print 'Hit prompt!' if $debug;
+ }
+ ],
+ );
+
+ $self->{lines} = \@lines;
+
+ return @lines;
+} # exec
+
+sub abortCmd (;$) {
+ my ($self, $timeout) = @_;
+
+=pod
+
+=head3 abortCmd
+
+Aborts the current command by sending a Control-C (assumed to be the
+interrupt character).
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item None
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $status
+
+1 if abort was successful (we got a command prompt back) or 0 if it
+was not.
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ # If timeout is specified for this exec then use it - otherwise
+ # use the object's defined timeout.
+ $timeout = $timeout ? $timeout : $self->{timeout};
+
+ # If timeout is set to 0 then the user wants an indefinite
+ # timeout. But Expect wants it to be undefined. So undef it if
+ # it's 0. Note this means we do not support Expect's "check it
+ # only one time" option.
+ undef $timeout if $timeout == 0;
+
+ # Set status to -2 indicating nothing happened! We should never
+ # return -2 (unless a command manages to set $? to -2!)
+ $self->{status} = -2;
+
+ $self->{handle}->send ("\cC");
+
+ $self->{handle}->expect (
+ $timeout,
+
+ [ timeout =>
+ sub {
+ $self->{status} = -1;
+ }
+ ],
+
+ [ $self->{prompt},
+ sub {
+ print "Hit prompt!" if $debug;
+ }
+ ],
+ );
+
+ return $self->{status};
+} # abortCmd
+
+sub status {
+ my ($self) = @_;
+
+=pod
+
+=head3 status
+
+Returns the status of the last command executed remotely.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item None
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $status
+
+Last status from exec.
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{status};
+} # status
+
+sub shellstyle {
+ my ($self) = @_;
+
+=pod
+
+=head3 shellstyle
+
+Returns the shellstyle
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item None
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item "sh"|"csh"
+
+sh: Bourne or csh: for csh style shells
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{shellstyle};
+} # shellstyle
+
+sub lines () {
+ my ($self) = @_;
+
+=pod
+
+=head3 lines
+
+Returns the lines array from the last command called by exec.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item None
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item @lines
+
+An array of lines from the last call to exec.
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return @{$self->{lines}};
+} # lines
+
+sub print_lines () {
+ my ($self) = @_;
+
+=pod
+
+=head3 print_lines
+
+Essentially prints the lines array to stdout
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item None
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Nothing
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ print "$_\n" foreach ($self->lines);
+
+ return;
+} # print_lines
+
+sub getHost () {
+ my ($self) = @_;
+
+=pod
+
+=head3 host
+
+Returns the host from the object.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item None
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $hostname
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{host};
+} # getHost
+
+sub DESTROY {
+ my ($self) = @_;
+
+ $self->{handle}->hard_close
+ if $self->{handle};
+
+ return;
+} # destroy
+
+sub getTimeout {
+ my ($self) = @_;
+
+=head3 getTimeout
+
+Returns the timeout from the object.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item None
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $timeout
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ return $self->{timeout} ? $self->{timeout} : $default_login_timeout;
+} # getTimeout
+
+sub setTimeout ($) {
+ my ($self, $timeout) = @_;
+
+=pod
+
+=head3 setTimeout ($timeout)
+
+Sets the timeout value for subsequent execution.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $timeout
+
+New timeout value to set
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $timeout
+
+Old timeout value
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my $oldTimeout = $self->getTimeout;
+ $self->{timeout} = $timeout;
+
+ return $oldTimeout;
+} # setTimeout
+
+1;
+
+=head1 DIAGNOSTICS
+
+=head2 Errors
+
+If verbose is turned on then connections or failure to connect will be
+echoed to stdout.
+
+=head3 Error text
+
+ <host> is not responding to <protocol>
+ Connected to <host> using <protocol> protocol
+ Unable to connect to <host> using <protocol> protocol
+
+=head2 Warnings
+
+Specifying cleartext passwords is not recommended for obvious security concerns.
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+Configuration files and environment variables.
+
+=over
+
+=item None
+
+=back
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+=for html <a href="http://search.cpan.org/~rgiersig/Expect-1.21/Expect.pod">Expect</a><b
+
+=head3 ClearSCM Perl Modules
+
+=for html <p><a href="/php/cvs_man.php?file=lib/Display.pm">Display</a></p>
+
+=head1 INCOMPATABILITIES
+
+None yet...
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this module.
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+This Perl Module is freely available; you can redistribute it and/or
+modify it under the terms of the GNU General Public License as
+published by the Free Software Foundation; either version 2 of the
+License, or (at your option) any later version.
+
+This Perl Module is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License (L<http://www.gnu.org/copyleft/gpl.html>) for more
+details.
+
+You should have received a copy of the GNU General Public License
+along with this Perl Module; if not, write to the Free Software Foundation,
+Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+reserved.
+
+=cut
\ No newline at end of file
--- /dev/null
+=pod
+
+=head1 NAME $RCSfile: SpreadSheet.pm,v $
+
+Object oriented interface to Excel Spreadsheets
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.1 $
+
+=item Created
+
+Tue Nov 20 10:40:53 PST 2012
+
+=item Modified
+
+$Date: 2012/11/21 02:53:06 $
+
+=back
+
+=head1 SYNOPSIS
+
+Provides access to Excel Spreadsheets
+
+ # Create SpreadSheet object
+ my $ss = SpreadSheet->new ($file)
+
+ # Get data in a sheet
+ my @rows = $ss->getData ($sheetName);
+
+ foreach (@rows) {
+ my %row = %$_;
+
+ foreach (keys %row) {
+ display "$_: $row{$_}";
+ } # foreach
+ } # foreach
+
+=head1 DESCRIPTION
+
+This module provides a simple, object oriented interface to a SpreadSheet.
+
+=head1 ROUTINES
+
+The following routines are exported:
+
+=cut
+
+package SpreadSheet;
+
+use strict;
+use warnings;
+
+use File::Basename;
+
+use Display;
+use OSDep;
+use TimeUtils;
+
+use Win32::OLE;
+use Win32::OLE::Const 'Microsoft Excel';
+
+sub _setError ($$) {
+ my ($self, $errmsg, $error) = @_;
+
+ $self->{errmsg} = $errmsg;
+ $self->{error} = $error;
+
+ return;
+} # _setError
+
+sub DESTROY {
+ my ($self) = @_;
+
+ undef $self->{excel} if $self->{excel};
+} # DESTROY
+
+sub new (;$) {
+ my ($class, $filename) = @_;
+
+=pod
+
+=head2 new ()
+
+Construct a new SpreadSheet object.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $filename
+
+Pathname to the spreadsheet file
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item SpreadSheet object
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my $self = bless {
+ filename => $filename,
+ excel => Win32::OLE->new ('Excel.Application', 'Quit'),
+ }, $class;
+
+ # Excel needs a Windows based absolute path
+ if ($^O eq 'cygwin') {
+ my @output = `cygpath -wa $self->{filename}`;
+ chomp @output;
+
+ $self->{filename} = $output[0];
+ } else {
+ require Cwd;
+
+ Cwd->import ('abs_path');
+
+ $self->{filename} = abs_path ($self->{filename});
+ } # if
+
+ $self->{book} = $self->{excel}->Workbooks->Open ($self->{filename});
+
+ $self->_setError ("Unable to open spreadsheet $self->{filename}", 1)
+ unless $self->{book};
+
+ return $self;
+} # new
+
+sub getSheet (;$) {
+ my ($self, $sheet) = @_;
+
+=pod
+
+=head2 getSheet ($)
+
+Return the data in the sheet specified
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $sheet
+
+The name of the sheet
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item @records
+
+Array of rows each represented by a hash. Note this assumes that the first row
+are field headings and are used as the keys for the hash.
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my @data;
+
+ unless ($self->{book}) {
+ $self->_setError ("Failed to open SpreadSheet ($self->{filename})", 1);
+
+ return;
+ } # unless
+
+ if ($sheet) {
+ $self->{sheet} = $self->{book}->Worksheets->Item ($sheet);
+ } else {
+ $sheet = 1;
+
+ $self->{sheet} = $self->{book}->Worksheets (1);
+ } # if
+
+ unless ($self->{sheet}) {
+ $self->_setError ("Unable to get sheet $sheet from spreadsheet $self->{filename}", 1);
+
+ return;
+ } # unless
+
+ # Now parse the spreadsheet
+ my $lastRow = $self->{sheet}->UsedRange->Find ({
+ What => '*',
+ SearchDirection => xlPrevious,
+ SearchOrder => xlByRows,
+ })->{Row};
+ my $lastColumn = $self->{sheet}->UsedRange->Find ({
+ What => '*',
+ SearchDirection => xlPrevious,
+ SearchOrder => xlByColumns,
+ })->{Column};
+
+ # Find columns by headings
+ my (@fields, $row, $column);
+
+ for ($column = 1; $column <= $lastColumn; $column++) {
+ $fields[$column - 1] = $self->{sheet}->Cells (1, $column)->{Value};
+ } # for
+
+ # Get data
+ for ($row = 2; $row <= $lastRow; $row++) {
+ my %row;
+
+ for ($column = 1; $column <= $lastColumn; $column++) {
+ $row{$fields[$column - 1]} =
+ $self->{sheet}->Cells ($row, $column)->{Value};
+
+ $row{$fields[$column - 1]} ||= '';
+ } # for
+
+ push @data, \%row;
+ } # for
+
+ return @data;
+} # getSheet
+
+1;
\ No newline at end of file
--- /dev/null
+=pod
+
+=head1 NAME $RCSfile: TimeUtils.pm,v $
+
+Common time utilities
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.13 $
+
+=item Created
+
+Fri Mar 12 10:17:44 PST 2004
+
+=item Modified
+
+$Date: 2012/11/13 23:34:13 $
+
+=back
+
+=head1 SYNOPSIS
+
+This module seeks to handle time and duration entities in a simple
+manner. Given a time(3) structure we have routines to format out, in a
+human readable form, a duration.
+
+ my $startTime = time;
+
+ # Do something that takes time...
+
+ # Display how long that took
+ display_duration $startTime;
+
+ # Displays how long that took into $log (See Logger.pm)
+ display_duration $startTime, $log;
+
+ # Get a date timestamp for today
+ my $yyyymmdd = format_yyyymmdd;
+
+ # Get a human readable duration between $startTime
+ # and the current time
+ my $duration = howlong $startTime, time;
+
+=head1 DESCRIPTION
+
+This module exports a few time/duration related routines
+
+=head1 ROUTINES
+
+The following routines are exported:
+
+=cut
+
+package TimeUtils;
+
+use strict;
+use warnings;
+
+use base "Exporter";
+use File::Spec;
+
+our @EXPORT = qw (
+ display_duration
+ format_yyyymmdd
+ howlong
+);
+
+use Display;
+use Logger;
+
+sub howlong ($;$) {
+ my ($start_time, $end_time) = @_;
+
+=pod
+
+=head2 howlong ($start_time, $end_time)
+
+Returns a string that represents a human readable version of the
+duration of time between $start_time and $end_time. For example, "1
+hour, 10 minues and 5 seconds".
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $start_time
+
+Time that represents the start time of the time period.
+
+=item $end_time
+
+Time that represents the end time of the time period. (Default;
+Current time)
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $duration string
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $end_time ||= time;
+
+ return if $start_time > $end_time;
+
+ my $difference = $end_time - $start_time;
+
+ my $seconds_per_min = 60;
+ my $seconds_per_hour = 60 * $seconds_per_min;
+ my $seconds_per_day = $seconds_per_hour * 24;
+
+ my $days = 0;
+ my $hours = 0;
+ my $minutes = 0;
+ my $seconds = 0;
+
+ if ($difference > $seconds_per_day) {
+ $days = int ($difference / $seconds_per_day);
+ $difference = $difference % $seconds_per_day;
+ } # if
+
+ if ($difference > $seconds_per_hour) {
+ $hours = int ($difference / $seconds_per_hour);
+ $difference = $difference % $seconds_per_hour;
+ } # if
+
+ if ($difference > $seconds_per_min) {
+ $minutes = int ($difference / $seconds_per_min);
+ $difference = $difference % $seconds_per_min;
+ } # if
+
+ $seconds = $difference;
+
+ my $day_str = '';
+ my $hour_str = '';
+ my $min_str = '';
+ my $sec_str = '';
+ my $duration = '';
+
+ if ($days > 0) {
+ $day_str = $days == 1 ? '1 day' : "$days days";
+ $duration = $day_str;
+ } # if
+
+ if ($hours > 0) {
+ $hour_str = $hours == 1 ? '1 hour' : "$hours hours";
+
+ if ($duration ne '') {
+ $duration .= ' ' . $hour_str;
+ } else {
+ $duration = $hour_str;
+ } # if
+ } # if
+
+ if ($minutes > 0) {
+ $min_str = $minutes == 1 ? '1 minute' : "$minutes minutes";
+
+ if ($duration ne '') {
+ $duration .= ' ' . $min_str;
+ } else {
+ $duration = $min_str;
+ } # if
+ } # if
+
+ if ($seconds > 0) {
+ $sec_str = $seconds == 1 ? '1 second' : "$seconds seconds";
+
+ if ($duration ne '') {
+ $duration .= ' ' . $sec_str;
+ } else {
+ $duration = $sec_str;
+ } # if
+ } # if
+
+ if ($duration eq '' and $seconds == 0) {
+ $duration = 'under 1 second';
+ } # if
+
+ return $duration;
+} # howlong
+
+sub display_duration ($;$) {
+ my ($start_time, $log) = @_;
+
+=pod
+
+=head2 display_duration ($start_time, $log)
+
+Displays the duration between $start_time and now to STDOUT (or
+optionally to log it to $log - See Logger)
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $start_time
+
+Time that represents the start time of the time period.
+
+=item $log
+
+Log object to long durtion to.
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Nothing
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ unless ($start_time) {
+ if ($log) {
+ $log->msg ('Finished in 0 seconds');
+ } else {
+ display 'Finished in 0 seconds';
+ } # if
+ } # unless
+
+ my $end_time = time;
+ my $duration = howlong $start_time, $end_time;
+
+ if ($log) {
+ $log->msg ("Finished in $duration");
+ } else {
+ display "Finished in $duration";
+ } # if
+
+ return;
+} # display_duration
+
+sub format_yyyymmdd ($) {
+ my ($time) = @_;
+
+=pod
+
+=head2 format_yyyymmdd ($time)
+
+Quickly returns a YYYYMMDD format date for $time. If $time is not
+specified then it returns today.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $time
+
+The $time to get the date from
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Date string in YYYYMMDD format for $time
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $time ||= time;
+
+ my ($sec, $min, $hour, $mday, $mon, $year) = localtime ($time);
+
+ $year += 1900;
+ $mon++;
+ $mon = $mon < 10 ? "0$mon" : $mon;
+ $mday = $mday < 10 ? "0$mday" : $mday;
+
+ return '$year$mon$mday';
+} # format_yyyymmdd
+
+1;
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+DEBUG: If set then $debug is set to this level.
+
+VERBOSE: If set then $verbose is set to this level.
+
+TRACE: If set then $trace is set to this level.
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<File::Spec|File::Spec>
+
+=head2 ClearSCM Perl Modules
+
+=for html <p><a href='/php/cvs_man.php?file=lib/Display.pm'>Display</a></p>
+
+=for html <p><a href='/php/cvs_man.php?file=lib/Logger.pm'>Logger</a></p>
+
+=head1 INCOMPATABILITIES
+
+None yet...
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this module.
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+This Perl Module is freely available; you can redistribute it and/or
+modify it under the terms of the GNU General Public License as
+published by the Free Software Foundation; either version 2 of the
+License, or (at your option) any later version.
+
+This Perl Module is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License (L<http://www.gnu.org/copyleft/gpl.html>) for more
+details.
+
+You should have received a copy of the GNU General Public License
+along with this Perl Module; if not, write to the Free Software Foundation,
+Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+reserved.
+
+=cut
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: $RCSfile: TriggerUtils.pm,v $
+# Revision: $Revision: 1.3 $
+# Description: Perl module for Trigger Utilities.
+# Author: Andrew@ClearSCM.com
+# Created: Fri Mar 12 10:17:44 PST 2004
+# Modified: $Date: 2011/01/09 01:04:33 $
+# Language: perl
+#
+# (c) Copyright 2005, ClearSCM, Inc. all rights reserved
+#
+################################################################################
+use warnings;
+
+package TriggerUtils;
+ use base "Exporter";
+ use File::Spec;
+ use OSDep;
+
+ our @EXPORT = qw (
+ clearmsg
+ clearlog
+ clearlogmsg);
+
+ my ($abs_path, $me, $log_path, $logfile, $user);
+
+ BEGIN {
+ # Extract relative path and basename from script name.
+ $0 =~ /(.*)[\/\\](.*)/;
+
+ $abs_path = (!defined $1) ? "." : File::Spec->rel2abs ($1);
+ $me = (!defined $2) ? $0 : $2;
+
+ # Setup paths
+ $log_path = "$abs_path$SEPARATOR..${SEPARATOR}triggers";
+
+ # Where to log things
+ $logfile = "$log_path${SEPARATOR}trigger.log";
+
+ # Get username to use to tag messages
+ $user = $ENV {CLEARCASE_USER};
+ } # BEGIN
+
+ sub clearmsg {
+ # Display a message to the user using clearprompt
+ my $message = shift;
+
+ `clearprompt proceed -newline -type error -prompt "$message" -mask abort -default abort`;
+ } # clearmsg
+
+ sub clearlog {
+ # Log a message to the log file
+ my $message = shift;
+
+ my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = localtime (time);
+ $mon++;
+ $year += 1900;
+ $hour = "0" . $hour if $hour < 10;
+ $min = "0" . $min if $min < 10;
+ my $date = "$mon/$mday/$year\@$hour:$min";
+
+ my $status = open (LOGFILE, ">>$logfile");
+
+ if (!defined $status) {
+ clearmsg "Catostrophic error:\n\n
+Unable to open logfile ($logfile) to log the following message:\n\n
+$message";
+ exit 1;
+ } # if
+
+ print LOGFILE "$me: $date: $user: $message\n";
+
+ close LOGFILE;
+ } # clearlog
+
+ sub clearlogmsg {
+ # Log message to log file then display it to user
+ my $message = shift;
+
+ clearlog $message;
+ clearmsg $message;
+ } # clearlogmsg
+
+1;
--- /dev/null
+=pod
+
+=head1 NAME $RCSfile: Utils.pm,v $
+
+Utils - Simple and often used utilities
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.26 $
+
+=item Created
+
+Thu Jan 5 15:15:29 PST 2006
+
+=item Modified
+
+$Date: 2013/03/28 21:18:55 $
+
+=back
+
+=head1 SYNOPSIS
+
+This module seeks to encapsulate useful utilities, things that are often done
+over and over again but who's classification is miscellaneous.
+
+ EnterDaemonMode
+
+ my @children = GetChildren ($pid);
+
+ my @lines = ReadFile ("/tmp/file");
+
+ print "Found foo!\n" if InArray ("foo", @bar);
+
+ my ($status, @output) = Execute ("ps -ef");
+
+=head1 DESCRIPTION
+
+A collection of utility type subroutines.
+
+=head1 ROUTINES
+
+The following routines are exported:
+
+=cut
+
+package Utils;
+
+use strict;
+use warnings;
+
+use FindBin;
+
+use base 'Exporter';
+
+use POSIX qw (setsid);
+use File::Spec;
+use Carp;
+
+use OSDep;
+use Display;
+
+our @EXPORT = qw (
+ EnterDaemonMode
+ Execute
+ GetChildren
+ InArray
+ PageOutput
+ PipeOutput
+ PipeOutputArray
+ ReadFile
+ RedirectOutput
+ StartPipe
+ Stats
+ StopPipe
+ Usage
+);
+
+sub EnterDaemonMode (;$$$) {
+ my ($logfile, $errorlog, $pidfile) = @_;
+
+=pod
+
+=head2 EnterDaemonMode ($logfile, $errorlog)
+
+There is a right way to enter "daemon mode" and this routine is for that. If you
+call EnterDaemonMode your process will be disassociated from the terminal and
+enter into a background mode just like a good daemon.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $logfile
+
+File name of where to redirect STDOUT for the daemon (Default: $NULL)
+
+=item $errorlog
+
+File name of where to redirect STDERR for the daemon (Default: $NULL)
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Doesn't return
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $logfile ||= $NULL;
+ $errorlog ||= $NULL;
+
+ my $file;
+
+ if ($pidfile) {
+ $pidfile = File::Spec->rel2abs ($pidfile);
+
+ open $file, '>', $pidfile
+ or warning "Unable to open pidfile $pidfile for writing - $!";
+ } # if
+
+ # Redirect STDIN to $NULL
+ open STDIN, '<', $NULL
+ or error "Can't read $NULL ($!)", 1;
+
+ # Redirect STDOUT to logfile
+ open STDOUT, '>>', $logfile
+ or error "Can't write to $logfile ($!)", 1;
+
+ # Redirect STDERR to errorlog
+ open STDERR, '>>', $errorlog
+ or error "Can't write to $errorlog ($!)", 1;
+
+ # Change the current directory to /
+ my $ROOT = $ARCH eq "windows" ? "C:\\" : "/";
+ chdir $ROOT
+ or error "Can't chdir to $ROOT ($!), 1";
+
+ # Turn off umask
+ umask 0;
+
+ # Now fork the daemon
+ defined (my $pid = fork)
+ or error "Can't create daemon ($!)", 1;
+
+ # Now the parent exits
+ exit if $pid;
+
+ # Write pidfile if specified
+ if ($pidfile) {
+ print $file "$$\n";
+
+ close $file;
+ } # if
+
+ # Set process to be session leader
+ setsid ()
+ or error "Can't start a new session ($!)", 1;
+
+ return;
+} # EnterDaemonMode
+
+sub Execute ($) {
+ my ($cmd) = @_;
+
+=pod
+
+=head2 Execute ($command)
+
+We all execute OS commands and then have to deal with the output and return
+codes and the like. How about an easy Execute subroutine. It takes one
+parameter, the command to execute, executes it and returns two parameters, the
+output in a nice chomped array and the status.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $command
+
+Command to execute
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item A status scalar and an array of lines output from the command (if any).
+
+Note, no redirection of STDERR is included. If you want STDERR included in
+STDOUT then do so in the $command passed in.
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ # Save $SIG{CHLD} so we can set it to 'DEFAULT' and then restore it later.
+ # Helps when you are doing process handling.
+ my $sigchld = $SIG{CHLD};
+
+ local $SIG{CHLD} = 'DEFAULT';
+
+ my @output = `$cmd`;
+ my $status = $?;
+
+ local $SIG{CHLD} = $sigchld;
+
+ chomp @output;
+
+ return ($status, @output);
+} # Execute
+
+sub GetChildren (;$) {
+ my ($pid) = @_;
+
+=pod
+
+=head2 GetChildren ($pid)
+
+Returns an array of children pids for the passed in $pid.
+
+NOTE: This assumes that the utility pstree exists and is in the callers PATH.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $pid
+
+$pid to return the subtree of (Default: pid of init)
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Array of children pids
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my @children = ();
+
+ $pid = 1 if !$pid;
+
+ my @output = `pstree -ap $pid`;
+
+ return @children if $? == 0;
+
+ chomp @output;
+
+ foreach (@output) {
+ # Skip the pstree process and the parent process - we want only
+ # our children.
+ next if /pstree/ or /\($pid\)/;
+
+ if (/\((\d+)\)/) {
+ push @children, $1;
+ } # if
+ } # foreach
+
+ return @children;
+} # GetChildren
+
+sub InArray ($@) {
+ my ($item, @array) = @_;
+
+=pod
+
+=head2 InArray ($item, @array)
+
+Find an item in an array.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $item
+
+Item to search for
+
+=item @array
+
+Array to search
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $TRUE if found - $FALSE otherwise
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ foreach (@array) {
+ return $TRUE if $item eq $_;
+ } # foreach
+
+ return $FALSE;
+} # InArray
+
+our $pipe;
+
+sub StartPipe ($;$) {
+ my ($to, $existingPipe) = @_;
+
+=pod
+
+=head2 StartPipe ($to, $existingPipe)
+
+Starts a pipeline
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $to
+
+String representing the other end of the pipe
+
+=item $existingPipe
+
+Already existing pipe handle (from a previous call to StartPipe)
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item A $pipe to used for PipeOutput
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ if ($existingPipe) {
+ close $existingPipe;
+
+ open $existingPipe, '|-', $to
+ or error "Unable to open pipe - $!", 1;
+
+ return $existingPipe;
+ } else {
+ open $pipe, '|-', $to
+ or error "Unable to open pipe - $!", 1;
+
+ return $pipe;
+ } # if
+} # StartPipe
+
+sub PipeOutputArray ($@) {
+ my ($to, @output) = @_;
+
+=pod
+
+=head2 PipeOutputArray ($to, @ouput)
+
+Pipes output to $to
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $to
+
+String representing the other end of the pipe to pipe @output to
+
+=item @output
+
+Output to pipe
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Nothing
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ open my $pipe, "|$to"
+ or error "Unable to open pipe - $!", 1;
+
+ foreach (@output) {
+ chomp;
+
+ print $pipe "$_\n";
+ } # foreach
+
+ return close $pipe;
+} # PipeOutputArray
+
+sub PipeOutput ($;$) {
+ my ($line, $topipe) = @_;
+
+=pod
+
+=head2 PipeOutput ($line, $topipe)
+
+Pipes a single line to $topipe
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $line
+
+Line to output to $topipe.
+
+=item $topipe
+
+A pipe returned by StartPipe (or our $pipe) to which the $line is piped.
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Nothing
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $topipe ||= $pipe;
+
+ chomp $line; chop $line if $line =~ /\r$/;
+
+ print $pipe "$line\n";
+
+ return;
+} # PipeOutput
+
+sub StopPipe (;$) {
+ my ($pipeToStop) = @_;
+
+=pod
+
+=head2 StopPipe ($pipe)
+
+Stops a $pipe.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $pipe
+
+Pipe to stop
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Nothing
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $pipeToStop ||= $pipe;
+
+ close $pipeToStop if $pipeToStop;
+} # StopPipe
+
+sub PageOutput (@) {
+ my (@output) = @_;
+
+=pod
+
+=head2 PageOutput (@ouput)
+
+Pages output to the screen
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item @output
+
+Output to page
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Nothing
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ if ($ENV{PAGER}) {
+ PipeOutputArray $ENV{PAGER}, @output;
+ } else {
+ print "$_\n"
+ foreach (@output);
+ } # if
+
+ return;
+} # PageOutput
+
+sub RedirectOutput ($$@) {
+ my ($to, $mode, @output) = @_;
+
+=pod
+
+=head2 RedirectOutput ($to, @ouput)
+
+Pages output to the screen
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $to
+
+Where to send the output
+
+=item @output
+
+Output to redirect
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Nothing
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ croak 'Mode must be > or >>'
+ unless ($mode eq '>' or $mode eq '>>');
+
+ open my $out, $mode, $to
+ or croak "Unable to open $to for writing - $!";
+
+ foreach (@output) {
+ chomp;
+ print $out "$_\n";
+ } # foreach
+
+ return;
+} # RedirectOutput
+
+sub ReadFile ($) {
+ my ($filename) = @_;
+
+=pod
+
+=head2 ReadFile ($filename)
+
+How many times have you coded a Perl subroutine, or just staight inline Perl to
+open a file, read all the lines into an array and close the file. This routine
+does that very thing along with the associated and proper checking of open
+failure and even trims the lines in the output array of trailing newlines? This
+routine returns an array of the lines in the filename passed in.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $filename
+
+Filename to read
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Array of lines in the file
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ open my $file, '<', $filename
+ or error "Unable to open $filename ($!)", 1;
+
+ if (wantarray) {
+ local $/ = "\n";
+
+ my @lines = <$file>;
+
+ close $file
+ or error "Unable to close $filename ($!)", 1;
+
+ my @cleansed_lines;
+
+ foreach (@lines) {
+ chomp;
+ chop if /\r/;
+ push @cleansed_lines, $_ if !/^#/; # Discard comment lines
+ } # foreach
+
+ return @cleansed_lines;
+ } else {
+ local $/;
+
+ return <$file>;
+ } # if
+} # ReadFile
+
+sub Stats ($;$) {
+ my ($total, $log) = @_;
+
+=pod
+
+=head2 Stats ($total, $log)
+
+Reports runtime stats
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $total
+
+Reference to a hash of total counters. The keys of the hash will be the labels
+and the values of the hash will be the counters.
+
+=item $log
+
+Logger object to log stats to (if specified)
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Nothing
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my $msg = "$FindBin::Script Run Statistics:";
+
+ if (scalar keys %$total) {
+ # Display statistics (if any)
+ if ($log) {
+ $log->msg ($msg);
+ } else {
+ display $msg;
+ } # if
+
+ foreach (sort keys %$total) {
+ $msg = $$total{$_} . "\t $_";
+
+ if ($log) {
+ $log->msg ($$total{$_} . "\t $_");
+ } else {
+ display $msg;
+ } # if
+ } # foreach
+ } # if
+
+ return;
+} # Stats
+
+sub Usage (;$) {
+ my ($msg) = @_;
+
+=pod
+
+=head2 Usage ($msg)
+
+Reports usage using perldoc
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $msg
+
+Message to output before doing perldoc
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Does not return
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ display $msg
+ if $msg;
+
+ system "perldoc $0";
+
+ exit 1;
+} # Usage
+
+END {
+ StopPipe;
+} # END
+
+1;
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+None
+
+=head1 DEPENDENCIES
+
+=head2 Perl Modules
+
+L<File::Spec|File::Spec>
+
+L<FindBin>
+
+L<POSIX>
+
+=head2 ClearSCM Perl Modules
+
+=for html <p><a href="/php/cvs_man.php?file=lib/Display.pm">Display</a></p>
+
+=for html <p><a href="/php/cvs_man.php?file=lib/Logger.pm">Logger</a></p>
+
+=for html <p><a href="/php/cvs_man.php?file=lib/OSDep.pm">OSDep</a></p>
+
+=head1 INCOMPATABILITIES
+
+None yet...
+
+=head1 BUGS AND LIMITATIONS
+
+There are no known bugs in this module.
+
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
+
+=head1 LICENSE AND COPYRIGHT
+
+This Perl Module is freely available; you can redistribute it and/or modify it
+under the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 2 of the License, or (at your option) any
+later version.
+
+This Perl Module is distributed in the hope that it will be useful, but WITHOUT
+ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+FOR A PARTICULAR PURPOSE. See the GNU General Public License
+(L<http://www.gnu.org/copyleft/gpl.html>) for more details.
+
+You should have received a copy of the GNU General Public License along with
+this Perl Module; if not, write to the Free Software Foundation, Inc., 59
+Temple Place - Suite 330, Boston, MA 02111-1307, USA. reserved.
+
+=cut
--- /dev/null
+////////////////////////////////////////////////////////////////////////////////
+//
+// File: $RCSFile$
+// Revision: $Revision: 1.1 $
+// Description: This JavaScript pops up a window for checkaddress.cgi
+// Author: Andrew@DeFaria.com
+// Created: Fri Nov 29 14:17:21 2002
+// Modified: $Date: 2013/06/12 14:05:47 $
+// Language: JavaScript
+//
+// (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
+//
+////////////////////////////////////////////////////////////////////////////////
+function checkaddress (form, user) {
+ if (form.email.value == "") {
+ alert ("Enter an address to check");
+ return false;
+ }
+
+ var features =
+ "height=200" + "," +
+ "location=no" + "," +
+ "menubar=no" + "," +
+ "status=no" + "," +
+ "toolbar=no" + "," +
+ "scrollbar=yes" + "," +
+ "width=400";
+
+ var url = "/maps/bin/checkaddress.cgi?";
+
+ if (user) {
+ url = url + "user=" + user + ";";
+ } // if
+
+ url = url + "sender=" + form.email.value;
+
+ window.open (url, "checkaddress", features);
+
+ return false;
+}
--- /dev/null
+////////////////////////////////////////////////////////////////////////////////
+//
+// File: $RCSFile$
+// Revision: $Revision: 1.1 $
+// Description: This JavaScript is included in the MAPS edit profile form to
+// check the fields of the form.
+// Author: Andrew@DeFaria.com
+// Created: Fri Nov 29 14:17:21 2002
+// Modified: $Date: 2013/06/12 14:05:47 $
+// Language: JavaScript
+//
+// (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
+//
+////////////////////////////////////////////////////////////////////////////////
+function validate (profile) {
+ with (profile) {
+ fullname = trim_trailing_spaces (fullname);
+ if (fullname.value == "") {
+ alert ("Full name is required!");
+ fullname.focus ();
+ return false;
+ } // if
+
+ email = trim_trailing_spaces (email);
+ if (email.value == "") {
+ alert ("We need your email address - in case you forget your password\nand we need to send it to you.");
+ email.focus ();
+ return false;
+ } else {
+ if (!valid_email_address (email)) {
+ alert ("That email address is invalid!\nMust be <username>@<domainname>\nFor example: Andrew@DeFaria.com.");
+ return false;
+ } // if
+ } // if
+
+ var password_msg =
+ "To change your password specify both your old and new passwords then\n" +
+ "repeat your new password in the fields provided\n\n" +
+ "To leave your password unchanged leave old, new and repeated\n" +
+ "password fields blank";
+
+ if (old_password.value != "") {
+ if (new_password.value == "") {
+ alert (password_msg);
+ new_password.focus ();
+ return false;
+ } else {
+ if (new_password.value.length < 6) {
+ alert ("Passwords must be greater than 6 characters.");
+ new_password.focus ();
+ return false;
+ } // if
+ } // if
+ if (repeated_password.value == "") {
+ alert (password_msg);
+ repeated_password.focus ();
+ return false;
+ } else {
+ if (repeated_password.value.length < 6) {
+ alert ("Passwords must be greater than 6 characters.");
+ repeated_password.focus ();
+ return false;
+ } // if
+ } // if
+ if (new_password.value != repeated_password.value) {
+ alert ("Sorry but the new password and repeated password are not the same!");
+ new_password.focus ();
+ return false;
+ } // if
+ } else {
+ if (new_password.value != "") {
+ alert (password_msg);
+ new_password.focus ();
+ return false;
+ } // if
+ if (repeated_password.value != "") {
+ alert (password_msg);
+ repeated_password.focus ();
+ return false;
+ } // if
+ } // if
+
+ if (MAPSPOP [0].checked) {
+ alert ("Sorry but MAPSPOP has not yet been implemented");
+ return false;
+ } // if
+
+ if (tag_and_forward [0].checked) {
+ alert ("Sorry but Tag & Forward has not yet been implemented");
+ return false;
+ } // if
+ } // with
+
+ return true;
+} // validate
--- /dev/null
+////////////////////////////////////////////////////////////////////////////////
+//
+// File: $RCSFile$
+// Revision: $Revision: 1.1 $
+// Description: This JavaScript is included in the MAPS login form to check
+// the fields of the form.
+// Author: Andrew@DeFaria.com
+// Created: Fri Nov 29 14:17:21 2002
+// Modified: $Date: 2013/06/12 14:05:47 $
+// Language: JavaScript
+//
+// (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
+//
+////////////////////////////////////////////////////////////////////////////////
+function validate (login) {
+ with (login) {
+ username = trim_trailing_spaces (username);
+
+ if (username.value == "") {
+ alert ("You must specify your Username!");
+ username.focus ();
+ return false;
+ } // if
+
+ if (password.value == "") {
+ alert ("You need to specify a password!");
+ password.focus ();
+ return false;
+ } // if
+
+ if (password.value.length < 6) {
+ alert ("Passwords must be greater than 6 characters.");
+ password.focus ();
+ return false;
+ } // if
+ } // with
+
+ return true;
+} // validate
--- /dev/null
+////////////////////////////////////////////////////////////////////////////////
+//
+// File: $RCSFile$
+// Revision: $Revision: 1.1 $
+// Description: This JavaScript is included in the MAPS registration form
+// to check the fields of the form.
+// Author: Andrew@DeFaria.com
+// Created: Fri Nov 29 14:17:21 2002
+// Modified: $Date: 2013/06/12 14:05:47 $
+// Language: JavaScript
+//
+// (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
+//
+////////////////////////////////////////////////////////////////////////////////
+function validate (subscription) {
+ with (subscription) {
+ fullname = trim_trailing_spaces (fullname);
+
+ if (fullname.value == "") {
+ alert ("You must tell us your real name!");
+ fullname.focus ();
+ return false;
+ } // if
+
+ sender = trim_trailing_spaces (sender);
+
+ if (sender.value == "") {
+ alert ("We need your email address!");
+ sender.focus ();
+ return false;
+ } else {
+ if (!valid_email_address (sender)) {
+ alert ("That email address is invalid!\n" +
+ "Must be <username>@<domainname>\n" +
+ "For example: Andrew@DeFaria.com.");
+ return false;
+ } // if
+ } // if
+ } // with
+
+ return true;
+} // validate
--- /dev/null
+////////////////////////////////////////////////////////////////////////////////
+//
+// File: $RCSFile$
+// Revision: $Revision: 1.1 $
+// Description: This JavaScript is included in the MAPS signup form to check
+// the fields of the form.
+// Author: Andrew@DeFaria.com
+// Created: Fri Nov 29 14:17:21 2002
+// Modified: $Date: 2013/06/12 14:05:47 $
+// Language: JavaScript
+//
+// (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
+//
+////////////////////////////////////////////////////////////////////////////////
+function validate (signup) {
+ with (signup) {
+ trim_trailing_spaces (userid);
+
+ if (userid.value == "") {
+ alert ("You must choose a name!");
+ userid.focus ();
+ return false;
+ } // if
+
+ if (userid.value.indexOf (" ") != -1) {
+ alert ("Userids cannot contain spaces");
+ userid.focus ();
+ return false;
+ } // if
+
+ trim_trailing_spaces (fullname);
+
+ if (fullname.value == "") {
+ alert ("Full name is required!");
+ fullname.focus ();
+ return false;
+ } // if
+
+ if (email.value == "") {
+ alert ("We need your email address - in case you forget " +
+ "your password\nand we need to send it to you.");
+ email.focus ();
+ return false;
+ } else {
+ var email_regex = /^\w+@\w+\.\w+$/;
+
+ if (!valid_email_address (email)) {
+ alert ("That email address is invalid!\n" +
+ "Must be <username>@<domainname>\n" +
+ "For example: Andrew@DeFaria.com.");
+ return false;
+ } // if
+ } // if
+
+ if (password.value == "") {
+ alert ("You need to specify a password!");
+ password.focus ();
+ return false;
+ } // if
+
+ if (password.value.length < 6) {
+ alert ("Passwords must be greater than 6 characters.");
+ password.focus ();
+ return false;
+ } // if
+
+ if (repeated_password.value == "") {
+ alert ("Please repeat your password.");
+ repeated_password.focus ();
+ return false;
+ } // if
+
+ if (repeated_password.value.length < 6) {
+ alert ("Passwords must be greater than 6 characters.");
+ repeated_password.focus ();
+ return false;
+ } // if
+
+ if (password.value != repeated_password.value) {
+ alert ("Sorry but the password and repeated password are not the same!");
+ password.focus ();
+ return false;
+ } // if
+
+ if (MAPSPOP [0].checked) {
+ alert ("Sorry but MAPSPOP has not be implemented yet!");
+ return false;
+ } // if
+
+ if (tag_and_forward [0].checked) {
+ alert ("Sorry but Tag & Forward has not be implemented yet!");
+ return false;
+ } // if
+ } // with
+
+ return true;
+} // validate
--- /dev/null
+////////////////////////////////////////////////////////////////////////////////
+//
+// File: $RCSFile$
+// Revision: $Revision: 1.1 $
+// Description: This JavaScript performs some simple validations for the
+// actions buttons on the list page.
+// Author: Andrew@DeFaria.com
+// Created: Fri Nov 29 14:17:21 2002
+// Modified: $Date: 2013/06/12 14:05:47 $
+// Language: JavaScript
+//
+// (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
+//
+////////////////////////////////////////////////////////////////////////////////
+function CheckOnly1Checked (form) {
+ var nbr_checked = 0;
+
+ // Loop through form and count the number of checked boxes
+ for (var i = 0; i < form.length; i++) {
+ var e = form.elements [i];
+ if (e.type == "checkbox" && e.checked) {
+ nbr_checked++;
+ } // if
+ } // for
+
+ if (nbr_checked == 1) {
+ return true;
+ } else if (nbr_checked > 1) {
+ alert ("You can only have one item marked for this action");
+ return false;
+ } else {
+ alert ("No lines were marked!");
+ return false;
+ } // if
+} // CheckOnly1Checked
+
+function CheckAtLeast1Checked (form) {
+ var nbr_checked = 0;
+
+ // Loop through form and count the number of checked boxes
+ for (var i = 0; i < form.length; i++) {
+ var e = form.elements [i];
+ if (e.type == "checkbox" && e.checked) {
+ nbr_checked++;
+ } // if
+ } // for
+
+ if (nbr_checked > 0) {
+ return true;
+ } else {
+ alert ("No lines were marked!");
+ return false;
+ } // if
+} // CheckAtLeast1Checked
+
+function NoneChecked (form) {
+ var nbr_checked = 0;
+
+ // Loop through form and count the number of checked boxes
+ for (var i = 0; i < form.length; i++) {
+ var e = form.elements [i];
+ if (e.type == "checkbox" && e.checked) {
+ nbr_checked++;
+ } // if
+ } // for
+
+ if (nbr_checked == 0) {
+ return true;
+ } else {
+ alert ("You must not have any checkboxes checked to perform this action");
+ return false;
+ } // if
+} // NoneChecked
+
+function AreYouSure (message) {
+ return window.confirm (message);
+} // AreYouSure
+
+function ClearAll (form) {
+ for (var i = 0; i < form.length; i++) {
+ var e = form.elements [i];
+ if (e.type == "checkbox" && e.checked) {
+ e.checked = false;
+ } // if
+ } // for
+
+ return false;
+} // ClearAll
+
+function CheckEntry (form) {
+ var current_entry = "";
+ var current_entry_nbr = 0;
+
+ var digits = /[^\d]+(\d+)/;
+ var parmname = /([^\d]+)\d+/;
+
+ for (var i = 0; i < form.length; i++) {
+ var e = form.elements [i];
+ if (e.type == "text") {
+ var name = e.name;
+ var parm = name.match (parmname);
+ var nbr = name.match (digits);
+ if (current_entry_nbr == 0) {
+ current_entry_nbr = nbr [1];
+ } // if
+ if (nbr [1] == current_entry_nbr) {
+ if (parm [1] == "pattern" || parm [1] == "domain") {
+ current_entry = current_entry + e.value;
+ } // if
+ } else {
+ if (current_entry == "") {
+ alert ("You must specify a value for Username and/or Domain for entry #" + current_entry_nbr);
+ return false;
+ } // if
+ current_entry_nbr = nbr [1];
+ current_entry = e.value;
+ } // if
+ } // if
+ } // for
+
+ if (current_entry == "") {
+ alert ("You must specify a value for Username and/or Domain for entry #" + current_entry_nbr);
+ return false;
+ } else {
+ return true;
+ } // if
+} // CheckEntry
+
+function ChangePage (page, type, lines) {
+ window.location = "/maps/php/list.php" + "?type=" + type + "&next=" + page * lines;
+} // ChangePage
+
--- /dev/null
+////////////////////////////////////////////////////////////////////////////////
+//
+// File: $RCSFile$
+// Revision: $Revision: 1.1 $
+// Description: JavaScript routine to fix an IE bug regarding the user of
+// tables in <div>'s that are not flush right
+// Author: Andrew@DeFaria.com
+// Created: Wed May 12 13:47:39 PDT 2004
+// Modified: $Date: 2013/06/12 14:05:47 $
+// Language: JavaScript
+//
+// (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
+//
+////////////////////////////////////////////////////////////////////////////////
+function AdjustTableWidth (table_name, width_percentage, margins) {
+ // This function fixes the problem with IE and tables. When a table
+ // is set to say 100% but is in a div that is not flush with the
+ // left side of the browser window, IE does not take into account
+ // the width of the div on the left. This function must be called
+ // after the close of the div that the table is contained in. It
+ // should also be called in the body tag for the onResize event in
+ // case the browser window is resized.
+
+ // If the browser is not IE and 5 or greater then return
+ if (navigator.userAgent.indexOf ("MSIE") == -1 ||
+ parseInt (navigator.appVersion) >= 5) {
+ return;
+ } // if
+
+ // If width_percentage was not passed in then set it to 100%
+ if (width_percentage == "" || width_percentage == null) {
+ width_percentage = 1;
+ } else {
+ width_percentage = width_percentage / 100;
+ } // if
+
+ // If margins were not set then use 15 pixels
+ if (margins == "" || margins == null) {
+ margins = 15;
+ } // if
+
+ // Get table name
+ var table = document.getElementById (table_name);
+
+ if (table == null) {
+ return; // no table, nothing to do!
+ } // if
+
+ // Get the width of the page in the browser
+ var body_width = document.body.clientWidth;
+
+ // Get the width of the left portion. Note this is hardcoded to the
+ // value of "leftbar" for the MAPS application
+ var sidebar_width = document.getElementById ("leftbar").clientWidth;
+
+ // Now compute the new table width by subtracting off the sizes of
+ // the sidebar_width and margins then multiply by the
+ // width_percentage
+ table.style.width =
+ (body_width - sidebar_width - margins) * width_percentage;
+;} // AdjustTableWidth
--- /dev/null
+////////////////////////////////////////////////////////////////////////////////
+//
+// File: $RCSFile$
+// Revision: $Revision: 1.1 $
+// Description: This JavaScript pops up a window for registerform.cgi
+// Author: Andrew@DeFaria.com
+// Created: Fri Nov 29 14:17:21 2002
+// Modified: $Date: 2013/06/12 14:05:47 $
+// Language: JavaScript
+//
+// (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
+//
+////////////////////////////////////////////////////////////////////////////////
+function register () {
+ var features =
+ "height=440" + "," +
+ "location=no" + "," +
+ "menubar=no" + "," +
+ "status=no" + "," +
+ "toolbar=no" + "," +
+ "scrollbar=yes" + "," +
+ "width=600";
+
+ window.open (
+ "http://earth:8080/maps/bin/registerform.cgi?userid=Andrew;sender=Andrew@DeFaria2.com",
+ "register",
+ features);
+} // register
--- /dev/null
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">\r
+<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US" xml:lang="en-US">\r
+<head>\r
+ <title>MAPS: Reports</title>\r
+ <link rev="made" href="mailto:Andrew%40DeFaria.com">\r
+ <link rel="stylesheet" type="text/css" href="/maps/css/MAPSStyle.css">\r
+ <script src="/maps/JavaScript/CheckAddress.js" type="text/javascript"></script>\r
+</head>\r
+<body>\r
+<div class="heading">\r
+<h2 class="header" align="center"><font class="standout">MAPS</font>\r
+Reports</h2>\r
+<h2 class="header" align="center"></h2>\r
+</div>\r
+<div class="content">\r
+<div class="leftbar">\r
+<div class="username">Welcome Andrew</div>\r
+<div class="menu"><a href="/maps/">MAPS Home<br>\r
+</a> <a href="/maps/bin/stats.cgi">Statistics<br>\r
+</a> <a href="/maps/bin/editprofile.cgi">Edit Profile<br>\r
+</a> <a href="/maps/Reports.html">Reports<br>\r
+</a> <a href="/maps/ManageLists.html">Manage Lists</a><a\r
+ href="/maps/Utilities.html"><br>\r
+</a> <a href="/maps/doc/">Help<br>\r
+</a> <a href="/maps/adm/">MAPS Admin<br>\r
+</a> <a href="/maps/?logout=yes">Logout</a></div>\r
+</div>\r
+<h2>Reports</h2>\r
+<ul>\r
+ <li>Returned messages by domain</li>\r
+ <li>Recent Activity<br>\r
+ </li>\r
+ <li>Space Usage</li>\r
+</ul>\r
+<br>\r
+<div class="copyright">Copyright © 2001-2003 - All rights reserved<br>\r
+<a href="http://defaria.com">Andrew DeFaria</a> <a\r
+ href="mailto:Andrew@DeFaria.com"><Andrew@DeFaria.com></a></div>\r
+</div>\r
+</body>\r
+</html>\r
--- /dev/null
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
+
+<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US" xml:lang="en-US">
+<head>
+ <title>MAPS: Signup</title>
+ <link rev="made" href="mailto:Andrew%40DeFaria.com">
+ <link rel="stylesheet" type="text/css" href="/maps/css/MAPSStyle.css">
+ <script src="/maps/JavaScript/MAPSUtils.js" type="text/javascript"></script>
+ <script src="/maps/JavaScript/CheckSignup.js" type="text/javascript"></script>
+</head>
+<body onResize="AdjustTableWidth ("signup");">
+
+<div class="heading">
+<h2 class="header" align="center"><font class="standout">MAPS</font>
+Spam Elimination System</h2>
+<h3 class="header" align="center">Sign up for MAPS</h3>
+</div>
+
+<div class="content">
+<div id="leftbar">
+<div class="username"> </div>
+<div class="menu">
+<a href="/maps/">MAPS Home</a><br>
+<a href="/maps/doc/">What is MAPS?</a><br>
+<a href="/maps/doc/SPAM.html">What is SPAM?</a><br>
+<a href="/maps/doc/Requirements.html">Requirements</a><br>
+<a href="/maps/SignupForm.html">Signup</a><br>
+<a href="/maps/doc/Using.php">Using MAPS</a><br>
+<a href="/maps/doc/">Help</a>
+</div>
+</div>
+
+<form method="post" action="/maps/bin/signup.cgi" enctype="application/x-www-form-urlencoded" onsubmit="return validate (this);">
+<table id="signup" cellpadding="2" cellspacing="0" border="1" width="100%"
+ align="center">
+ <tbody>
+ <tr>
+ <td class="label" width="135">Username:</td>
+ <td width="290"><input class="inputfield" type="text" size="25"
+ name="userid"></td>
+ <td class="notetext">Specify a username to log into MAPS<br>
+ </td>
+ </tr>
+ <tr>
+ <td class="label">Full name:</td>
+ <td><input class="inputfield" type="text" size="50"
+ name="fullname"></td>
+ <td class="notetext">Specify your full name<br>
+ </td>
+ </tr>
+ <tr>
+ <td class="label">Email Address:</td>
+ <td><input class="inputfield" type="text" size="50" name="email"></td>
+ <td class="notetext">Your email address is used if you are a <i>Tag
+ & Forward</i> user. This is the email address that MAPS
+ will forward your email to after it tags it. This email address is
+ also used in case you forget your password so that we can email you
+ your password. </td>
+ </tr>
+ <tr>
+ <td class="label">Password:</td>
+ <td><input class="inputfield" type="password" size="20"
+ name="password"></td>
+ <td class="notetext">Choose a password greater than 6 characters<br>
+ </td>
+ </tr>
+ <tr>
+ <td class="label">Repeat Password:</td>
+ <td><input class="inputfield" type="password" size="20"
+ name="repeated_password"></td>
+ <td class="notetext">Re-enter your password so we can be sure
+ you typed it correctly<br>
+ </td>
+ </tr>
+ <tr>
+ <td class="label">MAPSPOP User: </td>
+ <td class="label"><input type="radio" name="MAPSPOP" value="yes"
+ onclick="alert('Sorry but MAPSPOP has not yet been implemented'); return false;">Yes
+ <input type="radio" checked="checked" name="MAPSPOP" value="no">No</td>
+ <td class="notetext">MAPSPOP users need to download <a
+ href="/maps/bin/MAPSPOP.exe">MAPSPOP</a>.
+ See <a href="/maps/doc/UsingMAPSPOP.html"><i>Using MAPSPOP</i></a>
+ for more information.<br>
+ </td>
+ </tr>
+ <tr>
+ <td class="label">Keep history for:<br>
+ </td>
+ <td class="label">
+ <select name="history" class="inputfield">
+ <option>7</option>
+ <option>14</option>
+ <option selected="selected">30</option>
+ <option>60</option>
+ <option>90</option>
+ </select>
+ days </td>
+ <td class="notetext">This specifies how many days of history
+ that MAPS will keep before discarding returned messages.<br>
+ </td>
+ </tr>
+ <tr>
+ <td class="label">Dates in Stats Page<br>
+ </td>
+ <td class="label">
+ <select name="dates" class="inputfield">
+ <option selected="selected">7</option>
+ <option>14</option>
+ <option>21</option>
+ <option>30</option>
+ </select>
+ </td>
+ <td class="notetext">This specifies how many days are displayed
+ in the MAPS Stats Page.<br>
+ </td>
+ </tr>
+ <tr>
+ <td class="label">Entries per page:<br>
+ </td>
+ <td class="label">
+ <select name="days" class="inputfield">
+ <option selected="selected">10</option>
+ <option>20</option>
+ <option>30</option>
+ <option>40</option>
+ <option>50</option>
+ </select>
+ </td>
+ <td class="notetext">This specifies how many entries are
+ displayed per page in the online MAPS Reports.<br>
+ </td>
+ </tr>
+ <tr>
+ <td class="label"><i>Tag & Forward</i>:</td>
+ <td class="label"><input type="radio" name="tag_and_forward"
+ value="yes"
+ onclick="alert('Sorry but Tag & Forward has not yet been implemented'); return false;">Yes
+ <input type="radio" name="tag_and_forward" checked="checked"
+ value="no">No</td>
+ <td class="notetext"><i>Tag and Forward</i> means that MAPS
+ will not filter or save any email for you. Instead it will simply
+ add an X-MAPS header to your email indicating what MAPS would have
+ done with the email. This allows you to filter your email in your
+ local email client.<br>
+ </td>
+ </tr>
+ </tbody>
+</table>
+
+<div style="text-align: center;"><br>
+<input type="submit" value="Sign Up!"></div>
+<div class="copyright">Copyright © 2001-2004 - All rights reserved<br>
+<a href="http://defaria.com">Andrew DeFaria</a> <a
+ href="mailto:Andrew@DeFaria.com"><Andrew@DeFaria.com></a></div>
+</div>
+<script language='JavaScript1.2'>AdjustTableWidth ("signup");</script>
+</body>
+</html>
+
--- /dev/null
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">\r
+<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US" xml:lang="en-US">\r
+<head>\r
+ <title>MAPS: Administration</title>\r
+ <link rev="made" href="mailto:Andrew%40DeFaria.com">\r
+ <link rel="stylesheet" type="text/css" href="maps.css">\r
+ <script src="CheckAddress.js" type="text/javascript"></script>\r
+</head>\r
+<body>\r
+<div class="heading">\r
+<h2 class="header" align="center"><font class="standout">MAPS</font>\r
+Administration</h2>\r
+</div>\r
+<div class="content">\r
+<div class="leftbar">\r
+<div class="username">Welcome Andrew</div>\r
+<div class="menu"><a href="/maps/">MAPS Home<br>\r
+</a> <a href="/maps/bin/stats.cgi">Statistics<br>\r
+</a> <a href="/maps/bin/editprofile.cgi">Edit Profile<br>\r
+</a> <a href="/maps/Reports.html">Reports<br>\r
+</a> <a href="/maps/ManageLists.html">Manage Lists<br>\r
+</a> <a href="/maps/doc/">Help<br>\r
+</a> <a href="/maps/adm/">MAPS Admin<br>\r
+</a> <a href="/maps/?logout=yes">Logout</a></div>\r
+<div class="search">\r
+<form method="post" action="javascript://"\r
+ enctype="application/x-www-form-urlencoded"\r
+ onsubmit="checkaddress(this);" name="address">Check Address<input\r
+ type="text" name="email" size="14" maxlength="255"\r
+ onclick="document.address.email.value = '';" class="inputfield">\r
+ <div></div>\r
+</form>\r
+</div>\r
+<div class="quickstats">\r
+<h4 class="header" align="center">Today's Activity</h4>\r
+<table border="0" align="center" cellpadding="2" cellspacing="0">\r
+ <tbody>\r
+ <tr align="right">\r
+ <td class="smalllabel" align="right">Processed</td>\r
+ <td class="smallnumber" align="right">3</td>\r
+ <td class="smallnumber" align="right">n/a</td>\r
+ </tr>\r
+ <tr align="right">\r
+ <td class="smalllabel">Returned</td>\r
+ <td class="smallnumber"><a\r
+ href="detail.cgi?type=returned;date=2003-11-04">3</a></td>\r
+ <td class="smallnumber">100.0%</td>\r
+ </tr>\r
+ <tr align="right">\r
+ <td class="smalllabel">Nulllist</td>\r
+ <td class="smallnumber">0</td>\r
+ <td class="smallnumber"> 0.0%</td>\r
+ </tr>\r
+ <tr align="right">\r
+ <td class="smalllabel">Whitelist</td>\r
+ <td class="smallnumber">0</td>\r
+ <td class="smallnumber"> 0.0%</td>\r
+ </tr>\r
+ <tr align="right">\r
+ <td class="smalllabel">Blacklist</td>\r
+ <td class="smallnumber">0</td>\r
+ <td class="smallnumber"> 0.0%</td>\r
+ </tr>\r
+ <tr align="right">\r
+ <td class="smalllabel">Error</td>\r
+ <td class="smallnumber">0</td>\r
+ <td class="smallnumber"> 0.0%</td>\r
+ </tr>\r
+ <tr align="right">\r
+ <td class="smalllabel">Mailloop</td>\r
+ <td class="smallnumber">0</td>\r
+ <td class="smallnumber">n/a</td>\r
+ </tr>\r
+ <tr align="right">\r
+ <td class="smalllabel">Registered</td>\r
+ <td class="smallnumber">0</td>\r
+ <td class="smallnumber">n/a</td>\r
+ </tr>\r
+ </tbody>\r
+</table>\r
+</div>\r
+</div>\r
+<ul>\r
+ <li>Show Users</li>\r
+ <li>Delete a User</li>\r
+ <li>Space</li>\r
+</ul>\r
+<div class="copyright">Copyright © 2001-2003 - All rights reserved<br>\r
+<a href="http://defaria.com">Andrew DeFaria</a> <a\r
+ href="mailto:Andrew@DeFaria.com"><Andrew@DeFaria.com></a></div>\r
+</div>\r
+</body>\r
+</html>\r
--- /dev/null
+#!/usr/bin/perl
+#################################################################################
+#
+# File: $RCSfile: MAPS.pm,v $
+# Revision: $Revision: 1.1 $
+# Description: Main module for Mail Authentication and Permission System (MAPS)
+# Author: Andrew@DeFaria.com
+# Created: Fri Nov 29 14:17:21 2002
+# Modified: $Date: 2013/06/12 14:05:47 $
+# Language: perl
+#
+# (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+package MAPS;
+
+use strict;
+
+use FindBin;
+
+use MAPSDB;
+use MAPSLog;
+use MAPSFile;
+use MAPSUtil;
+use MIME::Entity;
+
+use vars qw (@ISA @EXPORT);
+use Exporter;
+
+@ISA = qw (Exporter);
+
+@EXPORT = qw (
+ Add2Blacklist
+ Add2Nulllist
+ Add2Whitelist
+ AddEmail
+ AddList
+ AddUser
+ AddUserOptions
+ Blacklist
+ CleanEmail
+ CleanLog
+ CleanList
+ CountMsg
+ Decrypt
+ DeleteEmail
+ DeleteList
+ DeleteLog
+ Encrypt
+ FindEmail
+ FindList
+ FindLog
+ FindUser
+ ForwardMsg
+ GetContext
+ GetEmail
+ GetList
+ GetLog
+ GetUser
+ GetUserOptions
+ ListLog
+ ListUsers
+ Login
+ Nulllist
+ OnBlacklist
+ OnNulllist
+ OnWhitelist
+ OptimizeDB
+ ReadMsg
+ ResequenceList
+ ReturnList
+ ReturnListEntry
+ ReturnMsg
+ ReturnMessages
+ ReturnSenders
+ SaveMsg
+ SearchEmails
+ SetContext
+ Space
+ UpdateList
+ UpdateUser
+ UpdateUserOptions
+ UserExists
+ Whitelist
+);
+
+my $mapsbase = "$FindBin::Bin/..";
+
+# Forwards
+sub Add2Blacklist;
+sub Add2Nulllist;
+sub Add2Whitelist;
+sub AddEmail;
+sub AddList;
+sub AddUser;
+sub AddUserOptions;
+sub Blacklist;
+sub CleanEmail;
+sub CleanLog;
+sub CountMsg;
+sub Decrypt;
+sub DeleteEmail;
+sub DeleteList;
+sub DeleteLog;
+sub Encrypt;
+sub FindEmail;
+sub FindList;
+sub FindLog;
+sub FindUser;
+sub ForwardMsg;
+sub GetContext;
+sub GetEmail;
+sub GetList;
+sub GetLog;
+sub GetUser;
+sub GetUserOptions;
+sub Login;
+sub Nulllist;
+sub OnBlacklist;
+sub OnNulllist;
+sub OnWhitelist;
+sub OptimizeDB;
+sub ReadMsg;
+sub ResequenceList;
+sub ReturnList;
+sub ReturnListEntry;
+sub ReturnMsg;
+sub ReturnMessages;
+sub ReturnSenders;
+sub SaveMsg;
+sub SearchEmails;
+sub SendMsg;
+sub SetContext;
+sub Space;
+sub UpdateList;
+sub UpdateUser;
+sub UpdateUserOptions;
+sub UserExists;
+sub Whitelist;
+
+BEGIN {
+ my $MAPS_username = "mapsadmin";
+ my $MAPS_password = "mapsadmin";
+
+ OpenDB $MAPS_username, $MAPS_password;
+} # BEGIN
+
+END {
+ CloseDB;
+} # END
+
+sub Add2Blacklist {
+ # Add2Blacklist will add an entry to the blacklist
+ my ($sender, $userid, $comment) = @_;
+
+ # First SetContext to the userid whose black list we are adding to
+ MAPSDB::SetContext $userid;
+
+ # Add to black list
+ AddList "black", $sender, 0, $comment;
+
+ # Log that we black listed the sender
+ Info "Added $sender to " . ucfirst $userid . "'s black list";
+
+ # Delete old emails
+ my $count = DeleteEmail $sender;
+
+ # Log out many emails we managed to remove
+ Info "Removed $count emails from $sender"
+} # Add2Blacklist
+
+sub Add2Nulllist ($$;$) {
+ # Add2Nulllist will add an entry to the nulllist
+ my ($sender, $userid, $comment) = @_;
+
+ # First SetContext to the userid whose null list we are adding to
+ MAPSDB::SetContext $userid;
+
+ # Add to null list
+ AddList "null", $sender, 0, $comment;
+
+ # Log that we null listed the sender
+ Info "Added $sender to " . ucfirst $userid . "'s null list";
+
+ # Delete old emails
+ my $count = DeleteEmail $sender;
+
+ # Log out many emails we managed to remove
+ Info "Removed $count emails from $sender"
+} # Add2Nulllist
+
+sub Add2Whitelist ($$;$) {
+ # Add2Whitelist will add an entry to the whitelist
+ my ($sender, $userid, $comment) = @_;
+
+ # First SetContext to the userid whose white list we are adding to
+ MAPSDB::SetContext $userid;
+
+ # Add to white list
+ AddList 'white', $sender, 0, $comment;
+
+ # Log that we registered a user
+ Logmsg "registered", $sender, "Registered new sender";
+
+ # Check to see if there are any old messages to deliver
+ my $handle = FindEmail $sender;
+
+ my ($dbsender, $subject, $timestamp, $message);
+
+ # Deliver old emails
+ my $messages = 0;
+ my $return_status = 0;
+
+ while (($userid, $dbsender, $subject, $timestamp, $message) = GetEmail $handle) {
+ last
+ unless $userid;
+
+ $return_status = Whitelist $sender, $message;
+
+ last
+ if $return_status;
+
+ $messages++;
+ } # while
+
+ # Done with $handle
+ $handle->finish;
+
+ # Return if we has a problem delivering email
+ return $return_status
+ if $return_status;
+
+ # Remove delivered messages.
+ DeleteEmail $sender;
+
+ return $messages;
+} # Add2Whitelist
+
+sub AddEmail ($$$) {
+ my ($sender, $subject, $data) = @_;
+
+ MAPSDB::AddEmail $sender, $subject, $data;
+} # AddEmail
+
+sub AddList ($$$;$) {
+ my ($listtype, $pattern, $sequence, $comment) = @_;
+
+ MAPSDB::AddList $listtype, $pattern, $sequence, $comment, CountMsg $pattern;
+} # AddList
+
+sub AddUser ($$$$) {
+ my ($userid, $realname, $email, $password) = @_;
+
+ return MAPSDB::AddUser $userid, $realname, $email, $password;
+} # AddUser
+
+sub AddUserOptions ($%) {
+ my ($userid, %options) = @_;
+
+ my $status;
+
+ foreach (keys (%options)) {
+ $status = MAPSDB::AddUserOption $userid, $_, $options{$_};
+ last if $status ne 0;
+ } # foreach
+
+ return $status;
+} # AddUserOptions
+
+sub Blacklist ($$$@) {
+ # Blacklist will send a message back to the $sender telling them that
+ # they've been blacklisted. Currently we save a copy of the message.
+ # In the future we should just disregard the message.
+ my ($sender, $sequence, $hit_count, @msg) = @_;
+
+ # Check to see if this sender has already emailed us.
+ my $msg_count = CountMsg $sender;
+
+ if ($msg_count lt 5) {
+ # Bounce email
+ SendMsg ($sender, "Your email has been discarded by MAPS", "$mapsbase/blacklist.html", @msg);
+ Logmsg "blacklist", $sender, "Sent blacklist reply";
+ } else {
+ Logmsg "mailloop", $sender, "Mail loop encountered";
+ } # if
+
+ RecordHit "black", $sequence, ++$hit_count if $sequence;
+} # Blacklist
+
+sub CleanEmail ($) {
+ my ($timestamp) = @_;
+
+ MAPSDB::CleanEmail $timestamp;
+} # CleanEmail
+
+sub CleanLog ($) {
+ my ($timestamp) = @_;
+
+ MAPSDB::CleanLog $timestamp;
+} # CleanLog
+
+sub CleanList ($;$) {
+ my ($timestamp, $listtype) = @_;
+
+ MAPSDB::CleanList $timestamp, $listtype;
+} # CleanList
+
+sub CountMsg ($) {
+ my ($sender) = @_;
+
+ return MAPSDB::CountMsg $sender;
+} # CountMsg
+
+sub Decrypt ($$) {
+ my ($password, $userid) = @_;
+
+ return MAPSDB::Decrypt $password, shift;
+} # Decrypt
+
+sub DeleteEmail ($) {
+ my ($sender) = @_;
+
+ return MAPSDB::DeleteEmail $sender;
+} # DeleteEmail
+
+sub DeleteList ($$) {
+ my ($type, $sequence) = @_;
+
+ return MAPSDB::DeleteList $type, $sequence;
+} # DeleteList
+
+sub DeleteLog ($) {
+ my ($sender) = @_;
+
+ return MAPSDB::DeleteLog $sender;
+} # DeleteLog
+
+sub Encrypt ($$) {
+ my ($password, $userid) = @_;
+
+ return MAPSDB::Encrypt $password, $userid;
+} # Encrypt
+
+sub FindEmail (;$) {
+ my ($sender) = @_;
+
+ return MAPSDB::FindEmail $sender;
+} # FindEmail
+
+sub FindList ($;$) {
+ my ($type, $sender) = @_;
+
+ return MAPSDB::FindList $type, $sender;
+} # FindList
+
+sub FindLog ($) {
+ my ($how_many) = @_;
+
+ my $start_at = 0;
+ my $end_at = MAPSDB::countlog ();
+
+ if ($how_many < 0) {
+ $start_at = $end_at - abs ($how_many);
+ $start_at = 0 if ($start_at < 0);
+ } # if
+
+ return MAPSDB::FindLog $start_at, $end_at;
+} # FindLog
+
+sub FindUser (;$) {
+ my ($userid) = @_;
+
+ return MAPSDB::FindUser $userid
+} # FindUser
+
+sub GetContext () {
+ return MAPSDB::GetContext ();
+} # GetContext
+
+sub GetEmail ($) {
+ my ($handle) = @_;
+
+ return MAPSDB::GetEmail $handle;
+} # GetEmail
+
+sub GetList ($) {
+ my ($handle) = @_;
+
+ return MAPSDB::GetList $handle;
+} # GetList
+
+sub GetLog ($) {
+ my ($handle) = @_;
+
+ return MAPSDB::GetLog $handle;
+} # GetLog
+
+sub GetUser ($) {
+ my ($handle) = @_;
+
+ return MAPSDB::GetUser $handle;
+} # GetUser
+
+sub GetUserOptions ($) {
+ my ($userid) = @_;
+
+ return MAPSDB::GetUserOptions $userid;
+} # GetUserOptions
+
+sub Login ($$) {
+ my ($userid, $password) = @_;
+
+ $password = Encrypt $password, $userid;
+
+ # Check if user exists
+ my $dbpassword = UserExists $userid;
+
+ # Return -1 if user doesn't exist
+ return -1 if !$dbpassword;
+
+ # Return -2 if password does not match
+ if ($password eq $dbpassword) {
+ MAPSDB::SetContext $userid;
+ return 0
+ } else {
+ return -2
+ } # if
+} # Login
+
+sub Nulllist ($;$$) {
+ # Nulllist will simply discard the message.
+ my ($sender, $sequence, $hit_count) = @_;
+
+ RecordHit "null", $sequence, ++$hit_count if $sequence;
+
+ # Discard Message
+ Logmsg "nulllist", $sender, "Discarded message";
+} # Nulllist
+
+sub OnBlacklist ($) {
+ my ($sender) = @_;
+
+ return CheckOnList "black", $sender;
+} # CheckOnBlacklist
+
+sub OnNulllist ($) {
+ my ($sender) = @_;
+
+ return CheckOnList "null", $sender;
+} # CheckOnNulllist
+
+sub OnWhitelist {
+ my ($sender, $userid) = @_;
+
+ if (defined $userid) {
+ MAPSDB::SetContext $userid;
+ } # if
+
+ return CheckOnList "white", $sender;
+} # OnWhitelist
+
+sub OptimizeDB () {
+ return MAPSDB::OptimizeDB ();
+} # OptimizeDB
+
+sub ReadMsg ($) {
+ # Reads an email message file from $input. Returns sender, subject,
+ # date and data, which is a copy of the entire message.
+ my ($input) = @_;
+
+ my $sender = "";
+ my $sender_long = "";
+ my $envelope_sender = "";
+ my $reply_to = "";
+ my $subject = "";
+ my $data = "";
+ my @data;
+
+ # Find first message's "From " line indicating start of message
+ while (<$input>) {
+ chomp;
+ last if /^From /;
+ } # while
+
+ # If we hit eof here then the message was garbled. Return indication of this
+ if (eof $input) {
+ $data = "Garbled message - unable to find From line";
+ return $sender, $sender_long, $reply_to, $subject, $data;
+ } # if
+
+ if (/From (\S*)/) {
+ $envelope_sender = $1;
+ $sender_long = $envelope_sender;
+ } # if
+
+ push @data, $_ if /^From /;
+
+ while (<$input>) {
+ chomp;
+ push @data, $_;
+
+ # Blank line indicates start of message body
+ last if ($_ eq "" || $_ eq "\r");
+
+ # Extract sender's address
+ if (/^from: .*/i) {
+ $_ = substr ($_, 6);
+ $sender_long = $_;
+ if (/<(\S*)@(\S*)>/) {
+ $sender = lc ("$1\@$2");
+ } elsif (/(\S*)@(\S*)\ /) {
+ $sender = lc ("$1\@$2");
+ } elsif (/(\S*)@(\S*)/) {
+ $sender = lc ("$1\@$2");
+ } # if
+ } elsif (/^subject: .*/i) {
+ $subject = substr ($_, 9);
+ } elsif (/^reply-to: .*/i) {
+ $_ = substr ($_, 10);
+ if (/<(\S*)@(\S*)>/) {
+ $reply_to = lc ("$1\@$2");
+ } elsif (/(\S*)@(\S*)\ /) {
+ $reply_to = lc ("$1\@$2");
+ } elsif (/(\S*)@(\S*)/) {
+ $reply_to = lc ("$1\@$2");
+ } # if
+ } else {
+ next;
+ } # if
+ } # while
+
+ # Read message body
+ while (<$input>) {
+ chomp;
+
+ last if (/^From /);
+ push @data, $_;
+ } # while
+
+ # Set file pointer back by length of the line just read
+ seek ($input, -length () - 1, 1) if !eof $input;
+
+ # Sanitize email addresses
+ $envelope_sender =~ s/\<//g;
+ $envelope_sender =~ s/\>//g;
+ $envelope_sender =~ s/\"//g;
+ $envelope_sender =~ s/\'//g;
+ $sender =~ s/\<//g;
+ $sender =~ s/\>//g;
+ $sender =~ s/\"//g;
+ $sender =~ s/\'//g;
+ $reply_to =~ s/\<//g;
+ $reply_to =~ s/\>//g;
+ $reply_to =~ s/\"//g;
+ $reply_to =~ s/\'//g;
+
+ # Now let's pack the @data array to a scalar
+ foreach (@data) {
+ $data = $data . $_ . "\n";
+ } # foreach
+
+ # Determine best addresses
+ $sender = $envelope_sender if $sender eq "";
+ $reply_to = $sender if $reply_to eq "";
+
+ return $sender, $sender_long, $reply_to, $subject, $data;
+} # ReadMsg
+
+sub ResequenceList ($$) {
+ my ($userid, $type) = @_;
+
+ return MAPSDB::ResequenceList $userid, $type;
+} # ResequenceList
+
+sub ReturnMessages ($$) {
+ my ($userid, $sender) = @_;
+
+ return MAPSDB::ReturnMessages $userid, $sender;
+} # ReturnMessages
+
+sub ReturnSenders ($$$;$$) {
+ my ($userid, $type, $next, $lines, $date) = @_;
+
+ return MAPSDB::ReturnSenders $userid, $type, $next, $lines, $date;
+} # ReturnSenders
+
+sub ReturnList ($$$) {
+ my ($type, $start_at, $lines) = @_;
+
+ return MAPSDB::ReturnList $type, $start_at, $lines;
+} # ReturnList
+
+sub ReturnListEntry ($$) {
+ my ($type, $sequence) = @_;
+
+ return MAPSDB::ReturnListEntry $type, $sequence;
+} # ReturnList
+
+# Added reply_to. Previously we passed reply_to into here as sender. This
+# caused a problem in that we were filtering as per sender but logging it
+# as reply_to. We only need reply_to for SendMsg so as to honor reply_to
+# so we now pass in both sender and reply_to
+sub ReturnMsg ($$$$) {
+ # ReturnMsg will send back to the $sender the register message.
+ # Messages are saved to be delivered when the $sender registers.
+ my ($sender, $reply_to, $subject, $data) = @_;
+
+ # Check to see if this sender has already emailed us.
+ my $msg_count = CountMsg $sender;
+
+ if ($msg_count < 5) {
+ # Return register message
+ my @msg;
+ foreach (split /\n/,$data) {
+ push @msg, "$_\n";
+ } # foreach
+ SendMsg $reply_to,
+ "Your email has been returned by MAPS",
+ "$mapsbase/register.html",
+ GetContext,
+ @msg
+ if $msg_count eq 0;
+ Logmsg "returned", $sender, "Sent register reply";
+ # Save message
+ SaveMsg $sender, $subject, $data;
+ } else {
+ Add2Nulllist $sender, GetContext, "Auto Null List - Mail loop";
+ Logmsg "mailloop", $sender, "Mail loop encountered";
+ } # if
+} # ReturnMsg
+
+sub SaveMsg ($$$) {
+ my ($sender, $subject, $data) = @_;
+
+ AddEmail $sender, $subject, $data;
+} # SaveMsg
+
+sub SearchEmails ($$) {
+ my ($userid, $searchfield) = @_;
+
+ return MAPSDB::SearchEmails $userid, $searchfield;
+} # SearchEmails
+
+sub ForwardMsg ($$$) {
+ my ($sender, $subject, $data) = @_;
+
+ my @lines = split /\n/, $data;
+
+ while ($_ = shift @lines) {
+ last if ($_ eq "" || $_ eq "\r");
+ } # while
+
+ my $to = "renn.leech\@compassbank.com";
+
+ my $msg = MIME::Entity->build (
+ From => $sender,
+ To => $to,
+ Subject => $subject,
+ Type => "text/html",
+ Data => \@lines,
+ );
+
+ # Send it
+ open MAIL, "| /usr/lib/sendmail -t -oi -oem"
+ or die "ForwardMsg: Unable to open pipe to sendmail $!";
+ $msg->print(\*MAIL);
+ close MAIL;
+} # ForwardMsg
+
+sub SendMsg ($$$$@) {
+ # SendMsg will send the message contained in $msgfile.
+ my ($sender, $subject, $msgfile, $userid, @spammsg) = @_;
+
+ my @lines;
+
+ # Open return message template file
+ open RETURN_MSG_FILE, "$msgfile"
+ or die "Unable to open return msg file ($msgfile): $!\n";
+
+ # Read return message template file and print it to $msg_body
+ while (<RETURN_MSG_FILE>) {
+ if (/\$userid/) {
+ # Replace userid
+ s/\$userid/$userid/;
+ } # if
+ if (/\$sender/) {
+ # Replace sender
+ s/\$sender/$sender/;
+ } #if
+ push @lines, $_;
+ } # while
+
+ # Close RETURN_MSG_FILE
+ close RETURN_MSG_FILE;
+
+ # Create the message, and set up the mail headers:
+ my $msg = MIME::Entity->build (
+ From => "MAPS\@DeFaria.com",
+ To => $sender,
+ Subject => $subject,
+ Type => "text/html",
+ Data => \@lines
+ );
+
+ # Need to obtain the spam message here...
+ $msg->attach (
+ Type => "message",
+ Disposition => "attachment",
+ Data => \@spammsg
+ );
+
+ # Send it
+ open MAIL, "| /usr/lib/sendmail -t -oi -oem"
+ or die "SendMsg: Unable to open pipe to sendmail $!";
+ $msg->print(\*MAIL);
+ close MAIL;
+} # SendMsg
+
+sub SetContext ($) {
+ my ($new_user) = @_;
+
+ return MAPSDB::SetContext $new_user;
+} # SetContext
+
+sub Space ($) {
+ my ($userid) = @_;
+
+ return MAPSDB::Space $userid;
+} # Space
+
+sub UpdateList ($$$$$$) {
+ my ($userid, $type, $pattern, $domain, $comment, $sequence) = @_;
+
+ return MAPSDB::UpdateList $userid, $type, $pattern, $domain, $comment, $sequence;
+} # UpdateList
+
+sub UpdateUser ($$$$) {
+ my ($userid, $fullname, $email, $password) = @_;
+
+ return MAPSDB::UpdateUser $userid, $fullname, $email, $password;
+} # UpdateUser
+
+sub UpdateUserOptions ($@) {
+ my ($userid, %options) = @_;
+
+ my $status;
+
+ foreach (keys (%options)) {
+ $status = MAPSDB::UpdateUserOption $userid, $_, $options{$_};
+ last if $status ne 0;
+ }
+
+ return $status;
+} # UpdateUserOptions
+
+sub UserExists ($) {
+ my ($userid) = @_;
+
+ return MAPSDB::UserExists $userid
+} # UserExists
+
+sub Whitelist ($$;$$) {
+ # Whitelist will deliver the message.
+ my ($sender, $data, $sequence, $hit_count) = @_;
+
+ my $userid = GetContext;
+
+ # Dump message into a file
+ open MESSAGE, ">/tmp/MAPSMessage.$$"
+ or Error "Unable to open message file (/tmp/MAPSMessage.$$): $!\n", return -1;
+
+ print MESSAGE $data;
+
+ close MESSAGE;
+
+ # Now call MAPSDeliver
+ my $status = system "$FindBin::Bin/MAPSDeliver $userid /tmp/MAPSMessage.$$";
+
+ unlink "/tmp/MAPSMessage.$$";
+
+ if ($status eq 0) {
+ Logmsg "whitelist", $sender, "Delivered message";
+ } else {
+ Error "Unable to deliver message - is MAPSDeliver setgid? - $!";
+ } # if
+
+ RecordHit "white", $sequence, ++$hit_count if $sequence;
+
+ return $status;
+} # Whitelist
+
+1;
--- /dev/null
+#!/usr/bin/perl
+#################################################################################
+#
+# File: $RCSfile: MAPSDB.pm,v $
+# Revision: $Revision: 1.1 $
+# Description: MAPS Database routines
+# Author: Andrew@DeFaria.com
+# Created: Fri Nov 29 14:17:21 2002
+# Modified: $Date: 2013/06/12 14:05:47 $
+# Language: perl
+#
+# (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+package MAPSDB;
+
+use strict;
+use vars qw (@ISA @EXPORT);
+use DBI;
+
+use MAPSUtil;
+
+@ISA = qw (Exporter);
+
+# Globals
+my $userid = $ENV{MAPS_USERNAME} ? $ENV{MAPS_USERNAME} : $ENV{USER};
+my %useropts;
+my $DB;
+
+@EXPORT = qw (
+ AddLog
+ CheckOnList
+ CloseDB
+ DBError
+ OpenDB
+ RecordHit
+);
+
+# Forwards
+sub AddEmail;
+sub AddList;
+sub AddLog;
+sub AddUser;
+sub AddUserOption;
+sub CheckOnList;
+sub CleanEmail;
+sub CleanLog;
+sub CleanList;
+sub CloseDB;
+sub CountMsg;
+sub DBError;
+sub Decrypt;
+sub DeleteEmail;
+sub DeleteList;
+sub Encrypt;
+sub FindEmail;
+sub FindList;
+sub FindLog;
+sub FindUser;
+sub GetContext;
+sub GetEmail;
+sub GetList;
+sub GetLog;
+sub GetNextSequenceNo;
+sub GetUser;
+sub GetUserInfo;
+sub GetUserOptions;
+sub OpenDB;
+sub OptimizeDB;
+sub ResequenceList;
+sub ReturnEmails;
+sub ReturnList;
+sub ReturnListEntry;
+sub SetContext;
+sub Space;
+sub UpdateList;
+sub UpdateUser;
+sub UpdateUserOption;
+sub UserExists;
+sub count;
+sub countlog;
+
+sub AddEmail ($$$) {
+ my ($sender, $subject, $data) = @_;
+
+ # "Sanitize" some fields so that characters that are illegal to SQL are escaped
+ $sender = 'Unknown'
+ if (!defined $sender || $sender eq '');
+ $sender = $DB->quote ($sender);
+ $subject = $DB->quote ($subject);
+ $data = $DB->quote ($data);
+
+ my $timestamp = UnixDatetime2SQLDatetime (scalar (localtime));
+ my $statement = "insert into email values (\"$userid\", $sender, $subject, \"$timestamp\", $data)";
+
+ $DB->do ($statement)
+ or DBError 'AddEmail: Unable to do statement', $statement;
+} # AddEmail
+
+sub AddList ($$$;$$) {
+ my ($listtype, $pattern, $sequence, $comment, $hitcount) = @_;
+
+ $hitcount ||= 0;
+
+ my ($user, $domain) = split /\@/, $pattern;
+
+ if (!$domain || $domain eq '') {
+ $domain = 'NULL';
+ $pattern = $DB->quote ($user);
+ } else {
+ $domain = "'$domain'";
+ if ($user eq '') {
+ $pattern = 'NULL';
+ } else {
+ $pattern = $DB->quote ($user);
+ } # if
+ } # if
+
+ if (!$comment || $comment eq '') {
+ $comment = 'NULL';
+ } else {
+ $comment = $DB->quote ($comment);
+ } # if
+
+ # Get next sequence #
+ if ($sequence eq 0) {
+ $sequence = GetNextSequenceNo $userid, $listtype;
+ } # if
+
+ my $timestamp = UnixDatetime2SQLDatetime (scalar (localtime));
+
+ my $statement = "insert into list values (\"$userid\", \"$listtype\", $pattern, $domain, $comment, $sequence, $hitcount, \"$timestamp\")";
+
+ $DB->do ($statement)
+ or DBError 'AddList: Unable to do statement', $statement;
+} # AddList
+
+sub AddLog ($$$) {
+ my ($type, $sender, $msg) = @_;
+
+ my $timestamp = UnixDatetime2SQLDatetime (scalar (localtime));
+ my $statement;
+
+ # Use quote to protect ourselves
+ $msg = $DB->quote ($msg);
+
+ if ($sender eq '') {
+ $statement = "insert into log values (\"$userid\", \"$timestamp\", null, \"$type\", $msg)";
+ } else {
+ $statement = "insert into log values (\"$userid\", \"$timestamp\", \"$sender\", \"$type\", $msg)";
+ } # if
+
+ $DB->do ($statement)
+ or DBError 'AddLog: Unable to do statement', $statement;
+} # AddLog
+
+sub AddUser ($$$$) {
+ my ($userid, $realname, $email, $password) = @_;
+
+ $password = Encrypt $password, $userid;
+
+ if (UserExists $userid) {
+ return 1;
+ } else {
+ my $statement = "insert into user values ('$userid', '$realname', '$email', '$password')";
+
+ $DB->do ($statement)
+ or DBError 'AddUser: Unable to do statement', $statement;
+ } # if
+
+ return 0;
+} # AddUser
+
+sub AddUserOption ($$$) {
+ my ($userid, $name, $value) = @_;
+
+ if (!UserExists $userid) {
+ return 1;
+ } # if
+
+ my $statement = "insert into useropts values ('$userid', '$name', '$value')";
+
+ $DB->do ($statement)
+ or DBError 'AddUserOption: Unable to do statement', $statement;
+
+ return 0;
+} # AddUserOption
+
+sub RecordHit ($$$) {
+ my ($listtype, $sequence, $hit_count) = @_;
+
+ my $current_date = UnixDatetime2SQLDatetime (scalar (localtime));
+
+ my $statement = "update list set hit_count=$hit_count, last_hit='$current_date' where userid='$userid' and type='$listtype' and sequence=$sequence";
+
+ $DB->do ($statement)
+ or DBError 'AddList: Unable to do statement', $statement;
+} # RecordHit
+
+sub CheckOnList ($$) {
+ # CheckOnList will check to see if the $sender is on the $listfile.
+ # Return 1 if found 0 if not.
+ my ($listtype, $sender) = @_;
+
+ my $status = 0;
+ my $rule;
+
+ my $statement = "select pattern, domain, comment, sequence, hit_count from list where userid = '$userid' and type = '$listtype'";
+
+ my $sth = $DB->prepare ($statement)
+ or DBError 'CheckOnList: Unable to prepare statement', $statement;
+
+ $sth->execute
+ or DBError 'CheckOnList: Unable to execute statement', $statement;
+
+ while (my @row = $sth->fetchrow_array) {
+ last if !@row;
+
+ my $hit_count = pop (@row);
+ my $sequence = pop (@row);
+ my $comment = pop (@row);
+ my $domain = pop (@row);
+ my $pattern = pop (@row);
+ my $email_on_file;
+
+ unless ($domain) {
+ $email_on_file = $pattern;
+ } else {
+ unless ($pattern) {
+ $email_on_file = '@' . $domain;
+ } else {
+ $email_on_file = $pattern . '@' . $domain;
+ } # if
+ } # unless
+
+ # Escape some special characters
+ $email_on_file =~ s/\@/\\@/;
+ $email_on_file =~ s/^\*/.\*/;
+
+ # We want to terminate the search string with a "$" iff there's an
+ # "@" in there. This is because some "email_on_file" may have no
+ # domain (e.g. "mailer-daemon" with no domain). In that case we
+ # don't want to terminate the search string with a "$" rather we
+ # wish to terminate it with an "@". But in the case of say
+ # "@ti.com" if we don't terminate the search string with "$" then
+ # "@ti.com" would also match "@tixcom.com"!
+ my $search_for = $email_on_file =~ /\@/
+ ? "$email_on_file\$"
+ : !defined $domain
+ ? "$email_on_file\@"
+ : $email_on_file;
+
+ if ($sender =~ /$search_for/i) {
+ $rule = "Matching rule: ($listtype:$sequence) \"$email_on_file\"";
+ $rule .= " - $comment" if $comment and $comment ne '';
+ $status = 1;
+
+ RecordHit $listtype, $sequence, ++$hit_count;
+
+ last;
+ } # if
+ } # while
+
+ $sth->finish;
+
+ return ($status, $rule);
+} # CheckOnList
+
+sub CleanEmail ($) {
+ my ($timestamp) = @_;
+
+ # First see if anything needs to be deleted
+ my $count = 0;
+
+ my $statement = "select count(*) from email where userid = '$userid' and timestamp < '$timestamp'";
+
+ # Prepare statement
+ my $sth = $DB->prepare ($statement)
+ or DBError 'CleanEmail: Unable to prepare statement', $statement;
+
+ # Execute statement
+ $sth->execute
+ or DBError 'CleanEmail: Unable to execute statement', $statement;
+
+ # Get return value, which should be how many entries were deleted
+ my @row = $sth->fetchrow_array;
+
+ # Done with $sth
+ $sth->finish;
+
+ # Retrieve returned value
+ unless ($row[0]) {
+ $count = 0
+ } else {
+ $count = $row[0];
+ } # unless
+
+ # Just return if there's nothing to delete
+ return $count if ($count eq 0);
+
+ # Delete emails for userid whose older than $timestamp
+ $statement = "delete from email where userid = '$userid' and timestamp < '$timestamp'";
+
+ # Prepare statement
+ $sth = $DB->prepare ($statement)
+ or DBError 'CleanEmail: Unable to prepare statement', $statement;
+
+ # Execute statement
+ $sth->execute
+ or DBError 'CleanEmail: Unable to execute statement', $statement;
+
+ return $count;
+} # CleanEmail
+
+sub CleanLog ($) {
+ my ($timestamp) = @_;
+
+ # First see if anything needs to be deleted
+ my $count = 0;
+
+ my $statement = "select count(*) from log where userid = '$userid' and timestamp < '$timestamp'";
+
+ # Prepare statement
+ my $sth = $DB->prepare ($statement)
+ or DBError $DB, 'CleanLog: Unable to prepare statement', $statement;
+
+ # Execute statement
+ $sth->execute
+ or DBError 'CleanLog: Unable to execute statement', $statement;
+
+ # Get return value, which should be how many entries were deleted
+ my @row = $sth->fetchrow_array;
+
+ # Done with $sth
+ $sth->finish;
+
+ # Retrieve returned value
+ unless ($row[0]) {
+ $count = 0
+ } else {
+ $count = $row[0];
+ } # unless
+
+ # Just return if there's nothing to delete
+ return $count if ($count eq 0);
+
+ # Delete log entries for userid whose older than $timestamp
+ $statement = "delete from log where userid = '$userid' and timestamp < '$timestamp'";
+
+ # Prepare statement
+ $sth = $DB->prepare ($statement)
+ or DBError 'CleanLog: Unable to prepare statement', $statement;
+
+ # Execute statement
+ $sth->execute
+ or DBError 'CleanLog: Unable to execute statement', $statement;
+
+ return $count;
+} # CleanLog
+
+sub CleanList ($;$) {
+ my ($timestamp, $listtype) = @_;
+
+ $listtype = 'null' if !$listtype;
+
+ # First see if anything needs to be deleted
+ my $count = 0;
+
+ my $statement = "select count(*) from list where userid = '$userid' and type = '$listtype' and last_hit < '$timestamp'";
+
+ # Prepare statement
+ my $sth = $DB->prepare ($statement)
+ or DBError $DB, 'CleanList: Unable to prepare statement', $statement;
+
+ # Execute statement
+ $sth->execute
+ or DBError 'CleanList: Unable to execute statement', $statement;
+
+ # Get return value, which should be how many entries were deleted
+ my @row = $sth->fetchrow_array;
+
+ # Done with $sth
+ $sth->finish;
+
+ # Retrieve returned value
+ $count = $row[0] ? $row[0] : 0;
+
+ # Just return if there's nothing to delete
+ return $count if ($count eq 0);
+
+ # Get data for these entries
+ $statement = "select type, sequence, hit_count from list where userid = '$userid' and type = '$listtype' and last_hit < '$timestamp'";
+
+ # Prepare statement
+ $sth = $DB->prepare ($statement)
+ or DBError 'CleanList: Unable to prepare statement', $statement;
+
+ # Execute statement
+ $sth->execute
+ or DBError 'CleanList: Unable to execute statement', $statement;
+
+ $count = 0;
+
+ while (my @row = $sth->fetchrow_array) {
+ last if !@row;
+
+ my $hit_count = pop (@row);
+ my $sequence = pop (@row);
+ my $listtype = pop (@row);
+
+ if ($hit_count == 0) {
+ $count++;
+
+ $statement = "delete from list where userid='$userid' and type='$listtype' and sequence=$sequence";
+ $DB->do ($statement)
+ or DBError 'CleanList: Unable to execute statement', $statement;
+ } else {
+ # Age entry: Sometimes entries are initially very popular and
+ # the $hit_count gets very high quickly. Then the domain is
+ # abandoned and no activity happens. One case recently observed
+ # was for phentermine.com. The $hit_count initially soared to
+ # 1920 within a few weeks. Then it all stopped as of
+ # 07/13/2007. Obvisously this domain was shutdown. With the
+ # previous aging algorithm of simply subtracting 1 this
+ # phentermine.com entry would hang around for over 5 years!
+ #
+ # So the tack here is to age the entry by dividing it's
+ # $hit_count in half. Sucessive halfing then will quickly age
+ # the entry down to size. However we don't want to age small
+ # $hit_count's too quickly, therefore once their numbers drop to
+ # < 30 we revert to the old method of subtracting 1.
+ if ($hit_count < 30) {
+ $hit_count--;
+ } else {
+ $hit_count = $hit_count / 2;
+ } # if
+
+ $statement = "update list set hit_count=$hit_count where userid='$userid' and type='$listtype' and sequence=$sequence;";
+ $DB->do ($statement)
+ or DBError 'CleanList: Unable to execute statement', $statement;
+ } # if
+ } # while
+
+ ResequenceList $userid, $listtype if $count > 0;
+
+ return $count;
+} # CleanList
+
+sub CloseDB () {
+ $DB->disconnect;
+} # CloseDB
+
+sub CountMsg ($) {
+ my ($sender) = @_;
+
+ return count ('email', "userid = '$userid' and sender like '%$sender%'");
+} # CountMsg
+
+sub DBError ($$) {
+ my ($msg, $statement) = @_;
+
+ print 'MAPSDB::' . $msg . "\nError #" . $DB->err . ' ' . $DB->errstr . "\n";
+
+ if ($statement) {
+ print "SQL Statement: $statement\n";
+ } # if
+
+ exit $DB->err;
+} # DBError
+
+sub Decrypt ($$) {
+ my ($password, $userid) = @_;
+
+ my $statement = "select decode('$password','$userid')";
+
+ my $sth = $DB->prepare ($statement)
+ or DBError 'Decrypt: Unable to prepare statement', $statement;
+
+ $sth->execute
+ or DBError 'Decrypt: Unable to execute statement', $statement;
+
+ # Get return value, which should be the encoded password
+ my @row = $sth->fetchrow_array;
+
+ # Done with $sth
+ $sth->finish;
+
+ return $row[0]
+} # Decrypt
+
+sub DeleteEmail ($) {
+ my $sender = shift;
+
+ my ($username, $domain) = split /@/, $sender;
+ my $condition;
+
+ if ($username eq '') {
+ $condition = "userid = '$userid' and sender like '%\@$domain'";
+ } else {
+ $condition = "userid = '$userid' and sender = '$sender'";
+ } # if
+
+ # First see if anything needs to be deleted
+ my $count = count ('email', $condition);
+
+ # Just return if there's nothing to delete
+ return $count if ($count eq 0);
+
+ my $statement = 'delete from email where ' . $condition;
+
+ $DB->do ($statement)
+ or DBError 'DeleteEmail: Unable to execute statement', $statement;
+
+ return $count;
+} # DeleteEmail
+
+sub DeleteList ($$) {
+ my ($type, $sequence) = @_;
+
+ # First see if anything needs to be deleted
+ my $count = count ('list', "userid = '$userid' and type = '$type' and sequence = '$sequence'");
+
+ # Just return if there's nothing to delete
+ return $count if ($count eq 0);
+
+ my $statement = "delete from list where userid = '$userid' and type = '$type' and sequence = '$sequence'";
+
+ $DB->do ($statement)
+ or DBError 'DeleteList: Unable to execute statement', $statement;
+
+ return $count;
+} # DeleteList
+
+sub DeleteLog ($) {
+ my ($sender) = @_;
+
+ my ($username, $domain) = split /@/, $sender;
+ my $condition;
+
+ if ($username eq '') {
+ $condition = "userid = '$userid' and sender like '%\@$domain'";
+ } else {
+ $condition = "userid = '$userid' and sender = '$sender'";
+ } # if
+
+ # First see if anything needs to be deleted
+ my $count = count ('log', $condition);
+
+ # Just return if there's nothing to delete
+ return $count if ($count eq 0);
+
+ my $statement = 'delete from log where ' . $condition;
+
+ $DB->do ($statement)
+ or DBError 'DeleteLog: Unable to execute statement', $statement;
+
+ return $count;
+} # DeleteLog
+
+sub Encrypt ($$) {
+ my ($password, $userid) = @_;
+
+ my $statement = "select encode('$password','$userid')";
+
+ my $sth = $DB->prepare ($statement)
+ or DBError 'Encrypt: Unable to prepare statement', $statement;
+
+ $sth->execute
+ or DBError 'Encrypt: Unable to execute statement', $statement;
+
+ # Get return value, which should be the encoded password
+ my @row = $sth->fetchrow_array;
+
+ # Done with $sth
+ $sth->finish;
+
+ return $row[0]
+} # Encrypt
+
+sub FindEmail (;$) {
+ my ($sender) = @_;
+
+ my $statement;
+
+ if (!defined $sender || $sender eq '') {
+ $statement = "select * from email where userid = '$userid'";
+ } else {
+ $statement = "select * from email where userid = '$userid' and sender = '$sender'";
+ } # if
+
+ my $sth = $DB->prepare ($statement)
+ or DBError 'FindEmail: Unable to prepare statement', $statement;
+
+ $sth->execute
+ or DBError 'FindEmail: Unable to execute statement', $statement;
+
+ return $sth;
+} # FindEmail
+
+sub FindList ($;$) {
+ my ($type, $sender) = @_;
+
+ my $statement;
+
+ unless ($sender) {
+ $statement = "select * from list where userid = '$userid' and type = '$type'";
+ } else {
+ my ($pattern, $domain) = split /\@/, $sender;
+ $statement = "select * from list where userid = '$userid' and type = '$type' " .
+ "and pattern = '$pattern' and domain = '$domain'";
+ } # unless
+
+ # Prepare statement
+ my $sth = $DB->prepare ($statement)
+ or DBError 'FindList: Unable to prepare statement', $statement;
+
+ # Execute statement
+ $sth->execute
+ or DBError 'FindList: Unable to execute statement', $statement;
+
+ # Get return value, which should be how many entries were deleted
+ return $sth;
+} # FindList
+
+sub FindLog ($$) {
+ my ($start_at, $end_at) = @_;
+
+ my $statement = "select * from log where userid = '$userid' order by timestamp limit $start_at, $end_at";
+
+ # Prepare statement
+ my $sth = $DB->prepare ($statement)
+ or DBError 'FindLog: Unable to prepare statement', $statement;
+
+ # Execute statement
+ $sth->execute
+ or DBError 'FindLog: Unable to execute statement', $statement;
+
+ # Get return value, which should be how many entries were deleted
+ return $sth;
+} # FindLog
+
+sub FindUser (;$) {
+ my ($userid) = @_;
+
+ my $statement;
+
+ if (!defined $userid || $userid eq '') {
+ $statement = 'select * from user';
+ } else {
+ $statement = "select * from user where userid = '$userid'";
+ } # if
+
+ my $sth = $DB->prepare ($statement)
+ or DBError 'FindUser: Unable to prepare statement', $statement;
+
+ $sth->execute
+ or DBError 'FindUser: Unable to execute statement', $statement;
+
+ return $sth;
+} # FindUser
+
+sub GetContext () {
+ return $userid;
+} # GetContext
+
+sub GetEmail ($) {
+ my ($sth) = @_;
+
+ my @email;
+
+ if (@email = $sth->fetchrow_array) {
+ my $message = pop @email;
+ my $timestamp = pop @email;
+ my $subject = pop @email;
+ my $sender = pop @email;
+ my $userid = pop @email;
+ return $userid, $sender, $subject, $timestamp, $message;
+ } else {
+ return undef;
+ } # if
+} # GetEmail
+
+sub GetList ($) {
+ my ($sth) = @_;
+
+ my @list;
+
+ if (@list = $sth->fetchrow_array) {
+ my $last_hit = pop @list;
+ my $hit_count = pop @list;
+ my $sequence = pop @list;
+ my $comment = pop @list;
+ my $domain = pop @list;
+ my $pattern = pop @list;
+ my $type = pop @list;
+ my $userid = pop @list;
+ return $userid, $type, $pattern, $domain, $comment, $sequence, $hit_count, $last_hit;
+ } else {
+ return undef;
+ } # if
+} # GetList
+
+sub GetLog ($) {
+ my ($sth) = @_;
+
+ my @log;
+
+ if (@log = $sth->fetchrow_array) {
+ my $message = pop @log;
+ my $type = pop @log;
+ my $sender = pop @log;
+ my $timestamp = pop @log;
+ my $userid = pop @log;
+ return $userid, $timestamp, $sender, $type, $message;
+ } else {
+ return undef;
+ } # if
+} # GetLog
+
+sub GetNextSequenceNo ($$) {
+ my ($userid, $listtype) = @_;
+
+ my $count = count ('list', "userid = '$userid' and type = '$listtype'");
+
+ return $count + 1;
+} # GetNextSequenceNo
+
+sub GetUser ($) {
+ my ($sth) = @_;
+
+ my @user;
+
+ if (@user = $sth->fetchrow_array) {
+ my $password = pop @user;
+ my $email = pop @user;
+ my $name = pop @user;
+ my $userid = pop @user;
+ return ($userid, $name, $email, $password);
+ } else {
+ return undef;
+ } # if
+} # GetUser
+
+sub GetUserInfo ($) {
+ my ($userid) = @_;
+
+ my $statement = "select name, email from user where userid='$userid'";
+
+ my $sth = $DB->prepare ($statement)
+ or DBError 'GetUserInfo: Unable to prepare statement', $statement;
+
+ $sth->execute
+ or DBError 'GetUserInfo: Unable to execute statement', $statement;
+
+ my @userinfo = $sth->fetchrow_array;
+ my $user_email = lc (pop @userinfo);
+ my $username = lc (pop @userinfo);
+
+ $sth->finish;
+
+ return ($username, $user_email);
+} # GetUserInfo
+
+sub GetUserOptions ($) {
+ my ($userid) = @_;
+
+ my $statement = "select * from useropts where userid = '$userid'";
+
+ my $sth = $DB->prepare ($statement)
+ or DBError 'GetUserOptions: Unable to prepare statement', $statement;
+
+ $sth->execute
+ or DBError 'GetUserOptions: Unable to execute statement', $statement;
+
+ my @useropts;
+
+ # Empty hash
+ %useropts = ();
+
+ while (@useropts = $sth->fetchrow_array) {
+ my $value = pop @useropts;
+ my $name = pop @useropts;
+ pop @useropts;
+ $useropts{$name} = $value;
+ } # while
+
+ $sth->finish;
+
+ return %useropts;
+} # GetUserOptions
+
+sub GetRows ($) {
+ my ($statement) = @_;
+
+ my $sth = $DB->prepare ($statement)
+ or DBError 'Unable to prepare statement' , $statement;
+
+ $sth->execute
+ or DBError 'Unable to execute statement' , $statement;
+
+ my @array;
+
+ while (my @row = $sth->fetchrow_array) {
+ foreach (@row) {
+ push @array, $_;
+ } # foreach
+ } # while
+
+ return @array;
+} # GetRows
+
+sub OpenDB ($$) {
+ my ($username, $password) = @_;
+
+ my $dbname = 'MAPS';
+ my $dbdriver = 'mysql';
+ my $dbserver = $ENV{MAPS_SERVER} ? $ENV{MAPS_SERVER} : 'jupiter';
+
+ if (!$DB || $DB eq '') {
+ $dbserver='localhost';
+ $DB = DBI->connect("DBI:$dbdriver:$dbname:$dbserver", $username, $password, {PrintError => 0})
+ or die "Couldn't connect to $dbname database as $username\n" . $DBI::errstr;
+ } # if
+
+ return $DB;
+} # OpenDB
+
+sub OptimizeDB () {
+ my $statement = 'lock tables email read, list read, log read, user read, useropts read';
+ my $sth = $DB->prepare ($statement)
+ or DBError 'OptimizeDB: Unable to prepare statement', $statement;
+
+ $sth->execute
+ or DBError 'OptimizeDB: Unable to execute statement', $statement;
+
+ $statement = 'check table email, list, log, user, useropts';
+ $sth = $DB->prepare ($statement)
+ or DBError 'OptimizeDB: Unable to prepare statement', $statement;
+
+ $sth->execute
+ or DBError 'OptimizeDB: Unable to execute statement', $statement;
+
+ $statement = 'unlock tables';
+ $sth = $DB->prepare ($statement)
+ or DBError 'OptimizeDB: Unable to prepare statement', $statement;
+
+ $sth->execute
+ or DBError 'OptimizeDB: Unable to execute statement', $statement;
+
+ $statement = 'optimize table email, list, log, user, useropts';
+ $sth = $DB->prepare ($statement)
+ or DBError 'OptimizeDB: Unable to prepare statement', $statement;
+
+ $sth->execute
+ or DBError 'OptimizeDB: Unable to execute statement', $statement;
+} # OptimizeDB
+
+sub ResequenceList ($$) {
+ my ($userid, $type) = @_;
+
+ if ($type ne 'white' && $type ne 'black' && $type ne 'null') {
+ return 1;
+ } # if
+
+ if (!UserExists $userid) {
+ return 2;
+ } # if
+
+ my $statement = "select sequence from list where userid = '$userid' ".
+ " and type = '$type' order by sequence";
+
+ my $sth = $DB->prepare ($statement)
+ or DBError 'ResequenceList: Unable to prepare statement', $statement;
+
+ $sth->execute
+ or DBError 'ResequenceList: Unable to execute statement', $statement;
+
+ my $sequence = 1;
+
+ while (my @row = $sth->fetchrow_array) {
+ last if !@row;
+ my $old_sequence = pop (@row);
+
+ if ($old_sequence != $sequence) {
+ my $update_statement = "update list set sequence = $sequence " .
+ "where userid = '$userid' and " .
+ "type = '$type' and sequence = $old_sequence";
+ $DB->do ($update_statement)
+ or DBError 'ResequenceList: Unable to do statement', $statement;
+ } # if
+
+ $sequence++;
+ } # while
+
+ return 0;
+} # ResequenceList
+
+# This subroutine returns an array of senders in reverse chronological
+# order based on time timestamp from the log table of when we returned
+# their message. The complication here is that a single sender may
+# send multiple times in a single day. So if spammer@foo.com sends
+# spam @ 1 second after midnight and then again at 2 Pm there will be
+# at least two records in the log table saying that we returned his
+# email. Getting records sorted by timestamp desc will have
+# spammer@foo.com listed twice. But we want him listed only once, as
+# the first entry in the returned array. Plus we may be called
+# repeatedly with different $start_at's. Therefore we need to process
+# the whole list of returns for today, eliminate duplicate entries for
+# a single sender then slice the resulting array.
+sub ReturnSenders ($$$;$$) {
+ my ($userid, $type, $start_at, $nbr_emails, $date) = @_;
+
+ $start_at ||= 0;
+
+ my $dateCond = '';
+
+ if ($date) {
+ my $sod = $date . ' 00:00:00';
+ my $eod = $date . ' 23:59:59';
+
+ $dateCond = "and timestamp > '$sod' and timestamp < '$eod'";
+ } # if
+
+ my $statement = <<END;
+select
+ sender,
+ timestamp
+from
+ log
+where
+ userid = '$userid' and
+ type = '$type'
+ $dateCond
+order by
+ timestamp desc
+END
+
+ my $sth = $DB->prepare ($statement)
+ or DBError 'ReturnSenders: Unable to prepare statement', $statement;
+
+ $sth->execute
+ or DBError 'ReturnSenders: Unable to execute statement', $statement;
+
+ # Watch the distinction between senders (plural) and sender (singular)
+ my (%senders, %sendersByTimestamp);
+
+ # Run through the results and add to %senders by sender key. This
+ # results in a hash that has the sender in it and the first
+ # timestamp value. Since we already sorted timestamp desc by the
+ # above select statement, and we've narrowed it down to only log
+ # message that occurred for the given $date, we will have a hash
+ # containing 1 sender and the latest timestamp for the day.
+ while (my $senderRef = $sth->fetchrow_hashref) {
+ my %sender = %{$senderRef};
+
+ $senders{$sender{sender}} = $sender{timestamp}
+ unless $senders{$sender{sender}};
+ } # while
+
+ $sth->finish;
+
+ # Make a hash whose keys are the timestamp (so we can later sort on
+ # them).
+ while (my ($key, $value) = each %senders) {
+ $sendersByTimestamp{$value} = $key;
+ } # while
+
+ my @senders;
+
+ # Sort by timestamp desc and push on to the @senders array
+ push @senders, $sendersByTimestamp{$_}
+ foreach (sort { $b cmp $a } keys %sendersByTimestamp);
+
+ # Finally slice for the given range
+ my $end_at = $start_at + $nbr_emails - 1;
+
+ $end_at = (@senders - 1)
+ if $end_at > @senders;
+
+ return (@senders) [$start_at .. $end_at];
+} # ReturnSenders
+
+sub ReturnMessages ($$) {
+ my ($userid, $sender) = @_;
+
+ # Note, the left(timestamp,16) chops off the seconds and the group
+ # by effectively squashes two emails received in the same minute to
+ # just one. We get a lot of double emails within the same minute. I
+ # think it's a result of the mailer configuration and it attempting
+ # to resend the message, not that it's the spammer sending just two
+ # emails in under a minute then going away. This will mean we will
+ # see fewer emails listed (essentially dups within one minute are
+ # squashed) yet they still will count towards the number of hits
+ # before we autonullist. We should squash these upon receipt, not
+ # upon report. Maybe latter...
+ my $statement = <<END;
+select
+ subject,
+ left(timestamp,16)
+from
+ email
+where
+ userid = '$userid' and
+ sender = '$sender'
+group by
+ left(timestamp,16) desc
+END
+
+ my $sth = $DB->prepare ($statement)
+ or DBError 'ReturnMessages: Unable to prepare statement', $statement;
+
+ $sth->execute
+ or DBError 'ReturnMessages: Unable to execute statement', $statement;
+
+ my @messages;
+
+ while (my @row = $sth->fetchrow_array) {
+ my $date = pop @row;
+ my $subject = pop @row;
+
+ push @messages, [$subject, $date];
+ } # while
+
+ $sth->finish;
+
+ return @messages;
+} # ReturnMessages
+
+sub ReturnEmails ($$$;$$) {
+ my ($userid, $type, $start_at, $nbr_emails, $date) = @_;
+
+ $start_at ||= 0;
+
+ my $statement;
+
+ if ($date) {
+ my $sod = $date . ' 00:00:00';
+ my $eod = $date . ' 23:59:59';
+
+ if ($type eq 'returned') {
+ $statement = <<END;
+select
+ log.sender
+from
+ log,
+ email
+where
+ log.sender = email.sender and
+ log.userid = '$userid' and
+ log.timestamp > '$sod' and
+ log.timestamp < '$eod' and
+ log.type = '$type'
+group by
+ log.sender
+limit
+ $start_at, $nbr_emails
+END
+ } else {
+ $statement = <<END;
+select
+ sender
+from
+ log
+where
+ userid = '$userid' and
+ timestamp > '$sod' and
+ timestamp < '$eod' and
+ type = '$type'
+group by
+ sender
+limit
+ $start_at, $nbr_emails
+END
+ } # if
+ } else {
+ if ($type eq 'returned') {
+ $statement = <<END;
+select
+ log.sender
+from
+ log,
+ email
+where
+ log.sender = email.sender and
+ log.userid = '$userid' and
+ log.type = '$type'
+group by
+ log.sender
+order by
+ log.timestamp desc
+limit
+ $start_at, $nbr_emails
+END
+ } else {
+ $statement = <<END;
+select
+ sender
+from
+ log
+where
+ userid = '$userid' and
+ type = '$type'
+group by
+ sender
+order by
+ timestamp desc
+limit
+ $start_at, $nbr_emails
+END
+ } # if
+ } # if
+
+ my $sth = $DB->prepare ($statement)
+ or DBError 'ReturnEmails: Unable to prepare statement', $statement;
+
+ $sth->execute
+ or DBError 'ReturnEmails: Unable to execute statement', $statement;
+
+ my @emails;
+
+ while (my $sender = $sth->fetchrow_array) {
+ my $earliestDate;
+
+ # Get emails for this sender. Format an array of subjects and timestamps.
+ my @messages;
+
+ $statement = "select timestamp, subject from email where userid = '$userid' " .
+ "and sender = '$sender'";
+
+ my $sth2 = $DB->prepare ($statement)
+ or DBError 'ReturnEmails: Unable to prepare statement', $statement;
+
+ $sth2->execute
+ or DBError 'ReturnEmails: Unable to execute statement', $statement;
+
+ while (my @row = $sth2->fetchrow_array) {
+ my $subject = pop @row;
+ my $date = pop @row;
+
+ if ($earliestDate) {
+ my $earliestDateShort = substr $earliestDate, 0, 10;
+ my $dateShort = substr $date, 0, 10;
+
+ if ($earliestDateShort eq $dateShort and
+ $earliestDate > $date) {
+ $earliestDate = $date
+ if $earliestDateShort eq $dateShort;
+ } # if
+ } else {
+ $earliestDate = $date;
+ } # if
+
+ push @messages, [$subject, $date];
+ } # while
+
+ # Done with sth2
+ $sth2->finish;
+
+ $earliestDate ||= '';
+
+ unless ($type eq 'returned') {
+ push @emails, [$earliestDate, [$sender, @messages]];
+ } else {
+ push @emails, [$earliestDate, [$sender, @messages]]
+ if @messages > 0;
+ } # unless
+ } # while
+
+ # Done with $sth
+ $sth->finish;
+
+ return @emails;
+} # ReturnEmails
+
+sub ReturnList ($$$) {
+ my ($type, $start_at, $lines) = @_;
+
+ $lines ||= 10;
+
+ my $statement;
+
+ if ($start_at) {
+ $statement = "select * from list where userid = '$userid' " .
+ "and type = '$type' order by sequence " .
+ "limit $start_at, $lines";
+ } else {
+ $statement = "select * from list where userid = '$userid' " .
+ "and type = '$type' order by sequence";
+ } # if
+
+ my $sth = $DB->prepare ($statement)
+ or DBError 'ReturnList: Unable to prepare statement', $statement;
+
+ $sth->execute
+ or DBError 'ReturnList: Unable to execute statement', $statement;
+
+ my @list;
+ my $i = 0;
+
+ while (my @row = $sth->fetchrow_array) {
+ last if $i++ > $lines;
+
+ my %list;
+
+ $list {last_hit} = pop @row;
+ $list {hit_count} = pop @row;
+ $list {sequence} = pop @row;
+ $list {comment} = pop @row;
+ $list {domain} = pop @row;
+ $list {pattern} = pop @row;
+ $list {type} = pop @row;
+ $list {userid} = pop @row;
+ push @list, \%list;
+ } # for
+
+ return @list;
+} # ReturnList
+
+sub ReturnListEntry ($$) {
+ my ($type, $sequence) = @_;
+
+ my $statement = "select * from list where userid = '$userid' " .
+ "and type = '$type' and sequence = '$sequence'";
+
+ my $sth = $DB->prepare ($statement)
+ or DBError 'ReturnListEntry: Unable to prepare statement', $statement;
+
+ $sth->execute
+ or DBError 'ReturnListEntry: Unable to execute statement', $statement;
+
+ my %list;
+ my @row = $sth->fetchrow_array;
+
+ $list {sequence} = pop @row;
+ $list {comment} = pop @row;
+ $list {domain} = pop @row;
+ $list {pattern} = pop @row;
+ $list {type} = pop @row;
+ $list {userid} = pop @row;
+
+ return %list;
+} # ReturnListEntry
+
+sub UpdateList ($$$$$$) {
+ my ($userid, $type, $pattern, $domain, $comment, $sequence) = @_;
+
+ if (!$pattern || $pattern eq '') {
+ $pattern = 'NULL';
+ } else {
+ $pattern = "'" . quotemeta ($pattern) . "'";
+ } # if
+
+ if (!$domain || $domain eq '') {
+ $domain = 'NULL';
+ } else {
+ $domain = "'" . quotemeta ($domain) . "'";
+ } # if
+
+ if (!$comment || $comment eq '') {
+ $comment = 'NULL';
+ } else {
+ $comment = "'" . quotemeta ($comment) . "'";
+ } # if
+
+ my $statement =
+ 'update list set ' .
+ "pattern = $pattern, domain = $domain, comment = $comment " .
+ "where userid = '$userid' and type = '$type' and sequence = $sequence";
+
+ $DB->do ($statement)
+ or DBError 'UpdateList: Unable to do statement', $statement;
+
+ return 0;
+} # UpdateList
+
+sub SearchEmails ($$) {
+ my ($userid, $searchfield) = @_;
+
+ my @emails;
+
+ my $statement =
+ "select sender, subject, timestamp from email where userid = '$userid' and (
+ sender like '%$searchfield%' or subject like '%$searchfield%')
+ order by timestamp desc";
+
+ my $sth = $DB->prepare ($statement)
+ or DBError 'SearchEmails: Unable to prepare statement', $statement;
+
+ $sth->execute
+ or DBError 'SearchEmails: Unable to execute statement', $statement;
+
+ while (my @row = $sth->fetchrow_array) {
+ my $date = pop @row;
+ my $subject = pop @row;
+ my $sender = pop @row;
+
+ push @emails, [$sender, $subject, $date];
+ } # while
+
+ $sth->finish;
+
+ return @emails;
+} # SearchEmails
+
+sub SetContext ($) {
+ my ($to_user) = @_;
+
+ my $old_user = $userid;
+
+ if (UserExists $to_user) {
+ $userid = $to_user;
+ GetUserOptions $userid;
+ return GetUserInfo $userid;
+ } else {
+ return 0;
+ } # if
+} # SetContext
+
+sub Space ($) {
+ my ($userid) = @_;
+
+ my $total_space = 0;
+ my %msg_space;
+
+ my $statement = "select * from email where userid = '$userid'";
+ my $sth = $DB->prepare ($statement)
+ or DBError 'Unable to prepare statement', $statement;
+
+ $sth->execute
+ or DBError 'Unable to execute statement', $statement;
+
+ while (my @row = $sth->fetchrow_array) {
+ last if !@row;
+ my $data = pop @row;
+ my $timestamp = pop @row;
+ my $subject = pop @row;
+ my $sender = pop @row;
+ my $user = pop @row;
+
+ my $msg_space =
+ length ($userid) +
+ length ($sender) +
+ length ($subject) +
+ length ($timestamp) +
+ length ($data);
+
+ $total_space += $msg_space;
+ $msg_space{$sender} += $msg_space;
+ } # while
+
+ $sth->finish;
+
+ return wantarray ? %msg_space : $total_space;
+} # Space
+
+sub UpdateUser ($$$$) {
+ my ($userid, $fullname, $email, $password) = @_;
+
+ if (!UserExists $userid) {
+ return 1;
+ } # if
+
+ my $statement;
+
+ if (!defined $password || $password eq '') {
+ $statement = "update user set userid='$userid', name='$fullname', email='$email' where userid='$userid'";
+ } else {
+ $password = Encrypt $password, $userid;
+ $statement = "update user set userid='$userid', name='$fullname', email='$email', password='$password' where userid='$userid'";
+ } # if
+
+ $DB->do ($statement)
+ or DBError 'UpdateUser: Unable to do statement', $statement;
+
+ return 0;
+} # UpdateUser
+
+sub UpdateUserOption ($$$) {
+ my ($userid, $name, $value) = @_;
+
+ if (!UserExists $userid) {
+ return 1;
+ } # if
+
+ my $statement = "update useropts set value='$value' where userid='$userid' and name='$name'";
+
+ $DB->do ($statement)
+ or DBError 'UpdateUserOption: Unable to do statement', $statement;
+
+ return 0;
+} # UpdateUserOptions
+
+sub UserExists ($) {
+ my ($userid) = @_;
+
+ return 0
+ unless $userid;
+
+ my $statement = "select userid, password from user where userid = '$userid'";
+
+ my $sth = $DB->prepare ($statement)
+ or DBError 'UserExists: Unable to prepare statement', $statement;
+
+ $sth->execute
+ or DBError 'UserExists: Unable to execute statement', $statement;
+
+ my @userdata = $sth->fetchrow_array;
+
+ $sth->finish;
+
+ return 0 if scalar (@userdata) == 0;
+
+ my $dbpassword = pop @userdata;
+ my $dbuserid = pop @userdata;
+
+ if ($dbuserid ne $userid) {
+ return 0;
+ } else {
+ return $dbpassword;
+ } # if
+} # UserExists
+
+sub count ($$) {
+ my ($table, $condition) = @_;
+
+ my $statement;
+
+ if ($condition) {
+ $statement = "select count(*) from $table where $condition";
+ } else {
+ $statement = "select count(*) from $table";
+ } # if
+
+ my $sth = $DB->prepare ($statement)
+ or DBError 'count: Unable to prepare statement', $statement;
+
+ $sth->execute
+ or DBError 'count: Unable to execute statement', $statement;
+
+ # Get return value, which should be how many message there are
+ my @row = $sth->fetchrow_array;
+
+ # Done with $sth
+ $sth->finish;
+
+ my $count;
+
+ # Retrieve returned value
+ unless ($row[0]) {
+ $count = 0
+ } else {
+ $count = $row[0];
+ } # unless
+
+ return $count
+} # count
+
+sub count_distinct ($$$) {
+ my ($table, $column, $condition) = @_;
+
+ my $statement;
+
+ if ($condition) {
+ $statement = "select count(distinct $column) from $table where $condition";
+ } else {
+ $statement = "select count(distinct $column) from $table";
+ } # if
+
+ my $sth = $DB->prepare ($statement)
+ or DBError 'count: Unable to prepare statement', $statement;
+
+ $sth->execute
+ or DBError 'count: Unable to execute statement', $statement;
+
+ # Get return value, which should be how many message there are
+ my @row = $sth->fetchrow_array;
+
+ # Done with $sth
+ $sth->finish;
+
+ # Retrieve returned value
+ unless ($row[0]) {
+ return 0;
+ } else {
+ return $row[0];
+ } # unless
+} # count_distinct
+
+sub countlog (;$$) {
+ my ($additional_condition, $type) = @_;
+
+ $type ||= '';
+
+ my $condition;
+
+ $condition = "userid=\'$userid\' ";
+
+ $condition .= "and $additional_condition"
+ if $additional_condition;
+
+ return count_distinct ('log', 'sender', $condition);
+} # countlog
+
+1;
--- /dev/null
+-------------------------------------------------------------------------------
+--
+-- File: $RCSFile$
+-- Revision: $Revision: 1.1 $
+-- Description: This file creates the MAPS database.
+-- Author: Andrew@DeFaria.com
+-- Created: Tue May 13 13:28:18 PDT 2003
+-- Modified: $Date: 2013/06/12 14:05:47 $
+-- Language: SQL
+--
+-- Copyright (c) 2000-2006, Andrew@DeFaria.com, all rights reserved
+--
+-------------------------------------------------------------------------------
+-- Warning: The following line will delete the old database!
+drop database if exists MAPS;
+
+-- Create a new database
+create database MAPS;
+
+-- Now let's focus on this new database
+use MAPS;
+
+-- user: Valid users and their passwords are contained here
+create table user (
+ userid varchar (128) not null,
+ name tinytext not null,
+ email varchar (128) not null,
+ password tinytext not null,
+ primary key (userid)
+) type=innodb; -- user
+
+-- useropts: User's options are stored here
+create table useropts (
+ userid varchar (128) not null,
+ name tinytext,
+ value varchar (128),
+ key user_index (userid),
+ foreign key (userid) references user (userid) on delete cascade
+) type=innodb; -- useropts
+
+-- email: Table that holds the email
+create table email (
+ userid varchar (128) not null,
+ sender varchar (128) not null,
+ subject varchar (255),
+ timestamp datetime,
+ data longblob,
+ key user_index (userid),
+ foreign key (userid) references user (userid) on delete cascade,
+ key sender_index (sender)
+) type=innodb; -- email
+
+-- whitelist: Table holds the users' whitelists
+create table list (
+ userid varchar (128) not null,
+ type enum ("white", "black", "null") not null,
+ pattern varchar (128),
+ domain varchar (128),
+ comment varchar (128),
+ sequence smallint,
+ hit_count integer,
+ last_hit datetime,
+ key user_index (userid),
+ key user_listtype (userid, type),
+ unique (userid, type, sequence),
+ foreign key (userid) references user (userid) on delete cascade
+) type=innodb; -- list
+
+-- log: Table to hold log information
+create table log (
+ userid varchar (128) not null,
+ timestamp datetime,
+ sender varchar (128),
+ type enum (
+ "blacklist",
+ "debug",
+ "error",
+ "info",
+ "mailloop",
+ "nulllist",
+ "registered",
+ "returned",
+ "whitelist"
+ ) not null,
+ message varchar (255) not null,
+ key user_index (userid),
+ foreign key (userid) references user (userid) on delete cascade
+) type=innodb; -- log
+
+-- Create users
+--grant all privileges
+-- on MAPS.* to mapsadmin@"%" identified by "mapsadmin";
+--grant select
+-- on MAPS.* to mapsreader@"%" identified by "reader";
+--grant insert, select, update, delete
+-- on MAPS.* to mapswriter@"%" identified by "writer";
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: $RCSfile: MAPSDeliver,v $
+# Revision: $Revision: 1.1 $
+# Description: This script simply delivers the mail. It is separated out so
+# it can be the only portion that is setgid to the group mail
+# for the purposes of being able to deliver the mail to the users
+# maildrop
+# Author: Andrew@DeFaria.com
+# Created: Fri Nov 29 14:17:21 2002
+# Modified: $Date: 2013/06/12 14:05:47 $
+# Language: perl
+#
+# (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+use strict;
+use warnings;
+
+use English;
+use FindBin;
+
+# Untaint $FindBin::Bin
+my $lib;
+
+BEGIN {
+ if ($FindBin::Bin =~ /^(.*)$/) {
+ $lib = $1;
+ } # if
+} # BEGIN
+
+use lib $lib;
+
+use MAPSFile;
+use MAPSDB;
+use MAPSLog;
+
+sub DeliverMail ($$) {
+ my ($userid, $msgfileName) = @_;
+
+ # Switch to group mail
+ $EGID = getgrnam "mail";
+
+ # Untaint $userid
+ if ($userid =~ /^([-\@\w.]+)$/) {
+ $userid = $1;
+ } # if
+
+ # Open maildrop file
+ open my $maildrop, '>>', "/var/mail/$userid"
+ or return "Unable to open maildrop file (/var/mail/$userid): $!";
+
+ # Open msgfile
+ open my $msgfile, '<', $msgfileName
+ or return "Unable to open msgfile ($msgfileName): $!";
+
+ # Lock file
+ Lock $maildrop;
+
+ # Write msgfile -> $maildrop
+ print $maildrop $_
+ while (<$msgfile>);
+
+ # Unlock the file
+ Unlock $maildrop;
+
+ # Close files
+ close $maildrop;
+ close $msgfile;
+
+ return;
+} # DeliverMail
+
+# Main
+die 'User id not specified' unless $ARGV [0];
+die 'Msgfile not specified' unless $ARGV [1];
+
+my $userid = shift @ARGV;
+my $msgfile = shift @ARGV;
+
+my $err = DeliverMail $userid, $msgfile;
+
+if ($err) {
+ OpenDB 'mapsadmin', 'mapsadmin';
+
+ MAPSDB::SetContext $userid;
+
+ Error $err;
+} # if
+
+exit 1 if $err;
+exit 0;
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: $RCSfile: MAPSFile.pm,v $
+# Revision: $Revision: 1.1 $
+# Description: File manipulation routines for MAPS.
+# Author: Andrew@DeFaria.com
+# Created: Fri Nov 29 14:17:21 2002
+# Modified: $Date: 2013/06/12 14:05:47 $
+# Language: perl
+#
+# (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+package MAPSFile;
+
+use strict;
+use vars qw (@ISA @EXPORT);
+
+use Fcntl ':flock'; # import LOCK_* constants
+
+use Exporter;
+@ISA = qw (Exporter);
+
+@EXPORT = qw (
+ Lock
+ Unlock
+);
+
+sub Lock {
+ my $file = shift;
+
+ flock ($file, LOCK_EX);
+ # and, in case someone appended while we were waiting...
+ seek ($file, 0, 2);
+} # lock
+
+sub Unlock {
+ my $file = shift;
+ flock ($file,LOCK_UN);
+} # unlock
+
+1;
--- /dev/null
+#!/usr/bin/perl
+#################################################################################
+#
+# File: $RCSfile: MAPSLog.pm,v $
+# Revision: $Revision: 1.1 $
+# Description: MAPS routines for logging.
+# Author: Andrew@DeFaria.com
+# Created: Fri Nov 29 14:17:21 2002
+# Modified: $Date: 2013/06/12 14:05:47 $
+# Language: perl
+#
+# (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+package MAPSLog;
+
+use strict;
+
+use FindBin;
+
+use lib $FindBin::Bin;
+
+use MAPSDB;
+use MAPSUtil;
+use vars qw (@ISA @EXPORT);
+use Exporter;
+
+@ISA = qw (Exporter);
+
+@EXPORT = qw (
+ Debug
+ Error
+ GetStats
+ Info
+ Logmsg
+ countlog
+ getstats
+ @Types
+);
+
+our @Types = (
+ 'returned',
+ 'whitelist',
+ 'blacklist',
+ 'registered',
+ 'mailloop',
+ 'nulllist'
+);
+
+sub countlog (;$$) {
+ my ($condition, $type) = @_;
+
+ return MAPSDB::countlog $condition, $type;
+} # countlog
+
+sub nbr_msgs ($) {
+ my ($sender) = @_;
+
+ return MAPSDB::FindEmail $sender;
+} # nbr_msgs
+
+sub GetStats (;$$) {
+ my ($nbr_days, $date) = @_;
+
+ $nbr_days ||= 1;
+ $date ||= Today2SQLDatetime
+
+ my %dates;
+
+ while ($nbr_days > 0) {
+ my $ymd = substr $date, 0, 10;
+ my $sod = $ymd . ' 00:00:00';
+ my $eod = $ymd . ' 23:59:59';
+
+ my %stats;
+
+ foreach (@Types) {
+ my $condition = "log.type=\'$_\' and (log.timestamp > \'$sod\' and log.timestamp < \'$eod\')";
+ $stats{$_} = countlog $condition, $_;
+ } # foreach
+
+ $dates{$ymd} = \%stats;
+
+ $date = SubtractDays $date, 1;
+ $nbr_days--;
+ } # while
+
+ return %dates
+} # GetStats
+
+sub Logmsg ($$$) {
+ my ($type, $sender, $msg) = @_;
+
+ AddLog $type, $sender, $msg;
+} # logmsg
+
+sub Debug ($) {
+ my ($msg) = @_;
+
+ Logmsg 'debug', '', $msg;
+} # Debug
+
+sub Error ($) {
+ my ($msg) = @_;
+
+ Logmsg 'error', '', $msg;
+} # Error
+
+sub Info ($) {
+ my ($msg) = @_;
+
+ Logmsg 'info', '', $msg;
+} # info
+
+1;
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: $RCSfile: MAPSUtil.pm,v $
+# Revision: $Revision: 1.1 $
+# Description: MAPS Utilities
+# Author: Andrew@DeFaria.com
+# Created: Fri Nov 29 14:17:21 2002
+# Modified: $Date: 2013/06/12 14:05:47 $
+# Language: perl
+#
+# (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+package MAPSUtil;
+
+use strict;
+use vars qw (@ISA @EXPORT);
+
+@ISA = qw (Exporter);
+
+@EXPORT = qw (
+ FormatDate
+ FormatTime
+ SQLDatetime2UnixDatetime
+ SubtractDays
+ Today2SQLDatetime
+ UnixDatetime2SQLDatetime
+);
+
+# Forwards
+sub FormatDate;
+sub FormatTime;
+sub SQLDatetime2UnixDatetime;
+sub SubtractDays;
+sub Today2SQLDatetime;
+sub UnixDatetime2SQLDatetime;
+
+sub FormatDate {
+ my $date = shift;
+
+ return substr ($date, 5, 2) .
+ "/" .
+ substr ($date, 8, 2) .
+ "/" .
+ substr ($date, 0, 4);
+} # FormatDate
+
+sub FormatTime {
+ my $time = shift;
+
+ my $hours = substr $time, 0, 2;
+ my $minutes = substr $time, 3, 2;
+ my $AmPm = $hours > 12 ? "Pm" : "Am";
+
+ $hours = $hours - 12 if $hours > 12;
+
+ return "$hours:$minutes $AmPm";
+} # FormatTime
+
+sub SQLDatetime2UnixDatetime {
+ my $sqldatetime = shift;
+
+ my %months = (
+ "01" => "Jan",
+ "02" => "Feb",
+ "03" => "Mar",
+ "04" => "Apr",
+ "05" => "May",
+ "06" => "Jun",
+ "07" => "Jul",
+ "08" => "Aug",
+ "09" => "Sep",
+ "10" => "Oct",
+ "11" => "Nov",
+ "12" => "Dec"
+ );
+
+ my $year = substr $sqldatetime, 0, 4;
+ my $month = substr $sqldatetime, 5, 2;
+ my $day = substr $sqldatetime, 8, 2;
+ my $time = FormatTime (substr $sqldatetime, 11);
+
+ return $months {$month} . " $day, $year \@ $time";
+} # SQLDatetime2UnixDatetime
+
+sub SubtractDays {
+ my $timestamp = shift;
+ my $nbr_of_days = shift;
+
+ my @months = (
+ 31, # January
+ 28, # February
+ 31, # March
+ 30, # April
+ 31, # May
+ 30, # June
+ 31, # July
+ 31, # August
+ 30, # September
+ 31, # October
+ 30, # November
+ 31 # Descember
+ );
+
+ my $year = substr $timestamp, 0, 4;
+ my $month = substr $timestamp, 5, 2;
+ my $day = substr $timestamp, 8, 2;
+
+ # Convert to Julian
+ my $days = 0;
+ my $m = 1;
+
+ foreach (@months) {
+ last if $m >= $month;
+ $m++;
+ $days += $_;
+ } # foreach
+
+ # Subtract $nbr_of_days
+ $days += $day - $nbr_of_days;
+
+ # Compute $days_in_year
+ my $days_in_year;
+
+ # Adjust if crossing year boundary
+ if ($days <= 0) {
+ $year--;
+ $days_in_year = (($year % 4) eq 0) ? 366 : 365;
+ $days = $days_in_year + $days;
+ } else {
+ $days_in_year = (($year % 4) eq 0) ? 366 : 365;
+ } # if
+
+ # Convert back
+ $month = 0;
+
+ while ($days > 28) {
+ # If remaining days is less than the current month then last
+ last if ($days <= $months[$month]);
+
+ # Subtract off the number of days in this month
+ $days -= $months[$month++];
+ } # while
+
+ # Prefix month with 0 if necessary
+ $month++;
+ if ($month < 10) {
+ $month = "0" . $month;
+ } # if
+
+ # Prefix days with 0 if necessary
+ if ($days eq 0) {
+ $days = "01";
+ } elsif ($days < 10) {
+ $days = "0" . $days;
+ } # if
+
+ return $year . "-" . $month . "-" . $days . substr $timestamp, 10;
+} # SubtractDays
+
+sub Today2SQLDatetime {
+ return UnixDatetime2SQLDatetime (scalar (localtime));
+} # Today2SQLDatetime
+
+sub UnixDatetime2SQLDatetime {
+ my $datetime = shift;
+
+ my $orig_datetime = $datetime;
+ my %months = (
+ "Jan" => "01",
+ "Feb" => "02",
+ "Mar" => "03",
+ "Apr" => "04",
+ "May" => "05",
+ "Jun" => "06",
+ "Jul" => "07",
+ "Aug" => "08",
+ "Sep" => "09",
+ "Oct" => "10",
+ "Nov" => "11",
+ "Dec" => "12"
+ );
+
+ # Some mailers neglect to put the leading day of the week field in.
+ # Check for this and compensate.
+ my $dow = substr $datetime, 0, 3;
+
+ if ($dow ne "Mon" &&
+ $dow ne "Tue" &&
+ $dow ne "Wed" &&
+ $dow ne "Thu" &&
+ $dow ne "Fri" &&
+ $dow ne "Sat" &&
+ $dow ne "Sun") {
+ $datetime = "XXX, " . $datetime;
+ } # if
+
+ # Some mailers have day before month. We need to correct this
+ my $day = substr $datetime, 5, 2;
+
+ if ($day =~ /\d /) {
+ $day = "0" . (substr $day, 0, 1);
+ $datetime = (substr $datetime, 0, 5) . $day . (substr $datetime, 6);
+ } # if
+
+ if ($day !~ /\d\d/) {
+ $day = substr $datetime, 8, 2;
+ } # if
+
+ # Check for 1 digit date
+ if ((substr $day, 0, 1) eq " ") {
+ $day = "0" . (substr $day, 1, 1);
+ $datetime = (substr $datetime, 0, 8) . $day . (substr $datetime, 10);
+ } # if
+
+ my $year = substr $datetime, 20, 4;
+
+ if ($year !~ /\d\d\d\d/) {
+ $year = substr $datetime, 12, 4;
+ if ($year !~ /\d\d\d\d/) {
+ $year = substr $datetime, 12, 2;
+ } #if
+ } # if
+
+ # Check for 2 digit year. Argh!
+ if (length $year == 2 or (substr $year, 2, 1) eq " ") {
+ $year = "20" . (substr $year, 0, 2);
+ $datetime = (substr $datetime, 0, 12) . "20" . (substr $datetime, 12);
+ } # if
+
+ my $month_name = substr $datetime, 4, 3;
+
+ if (!defined $months {$month_name}) {
+ $month_name = substr $datetime, 8, 3;
+ } # if
+ my $month = $months {$month_name};
+
+ my $time = substr $datetime, 11, 8;
+
+ if ($time !~ /\d\d:\d\d:\d\d/) {
+ $time = substr $datetime, 17, 8
+ } # if
+
+ if (!defined $year) {
+ print "WARNING: Year undefined for $orig_datetime\nReturning today's date\n";
+ return Today2SQLDatetime;
+ } # if
+ if (!defined $month) {
+ print "Month undefined for $orig_datetime\nReturning today's date\n";
+ return Today2SQLDatetime;
+ } # if
+ if (!defined $day) {
+ print "Day undefined for $orig_datetime\nReturning today's date\n";
+ return Today2SQLDatetime;
+ } # if
+ if (!defined $time) {
+ print "Time undefined for $orig_datetime\nReturning today's date\n";
+ return Today2SQLDatetime;
+ } # if
+
+ return "$year-$month-$day $time";
+} # UnixDatetime2SQLDatetime
+
+1;
--- /dev/null
+#################################################################################
+#
+# File: $RCSfile: MAPSWeb.pm,v $
+# Revision: $Revision: 1.1 $
+# Description: Routines for generating portions of MAPSWeb
+# Author: Andrew@DeFaria.com
+# Created: Fri Nov 29 14:17:21 2002
+# Modified: $Date: 2013/06/12 14:05:47 $
+# Language: perl
+#
+# (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+package MAPSWeb;
+
+use strict;
+
+use FindBin;
+
+use lib $FindBin::Bin;
+
+use MAPS;
+use MAPSLog;
+use MAPSUtil;
+
+use CGI qw (:standard *table start_Tr end_Tr start_div end_div);
+use vars qw (@ISA @EXPORT);
+
+use Exporter;
+
+@ISA = qw (Exporter);
+
+@EXPORT = qw (
+ Debug
+ DisplayError
+ Footing
+ Heading
+ NavigationBar
+);
+
+sub getquickstats {
+ my $date = shift;
+
+ my %dates = GetStats (1, $date);
+
+ foreach (@MAPSLog::Types) {
+ $dates{$date}{processed} += $dates{$date}{$_};
+ } # foreach
+
+ return %dates;
+} # getquickstats
+
+sub displayquickstats {
+ # Quick stats are today only.
+ my $today = Today2SQLDatetime;
+ my $time = substr $today, 11;
+ my $date = substr $today, 0, 10;
+ my %dates = getquickstats $date;
+
+ print start_div {-class => 'quickstats'};
+ print h4 {-class => 'header',
+ -align => 'center'},
+ 'Today\'s Activity';
+ print p {-align => 'center'},
+ b ('as of ' . FormatTime ($time));
+ print start_table {
+ -align => 'center',
+ -border => 0,
+ -cellspacing => 0,
+ -cellpadding => 2};
+ print start_Tr {-align => 'right'};
+ print
+ td {-class => 'smalllabel',
+ -align => 'right'},
+ 'Processed';
+ print
+ td {-class => 'smallnumber',
+ -align => 'right'},
+ $dates{$date}{'processed'};
+ print
+ td {-class => 'smallnumber',
+ -align => 'right'},
+ 'n/a';
+ print end_Tr;
+
+ foreach (@MAPSLog::Types) {
+ print start_Tr {-align => 'right'};
+
+ my $value = $dates{$date}{$_};
+ my $percent;
+ if ($_ eq 'mailloop' || $_ eq 'registered') {
+ $percent = 'n/a';
+ } else {
+ $percent = $dates{$date}{processed} == 0 ?
+ 0 : $dates{$date}{$_} / $dates{$date}{processed} * 100;
+ $percent = sprintf '%5.1f%s', $percent, '%';
+ } # if
+ my $stat = $value == 0 ?
+ 0 : a {-href => "detail.cgi?type=$_;date=$date"}, $value;
+ print
+ td {-class => 'smalllabel'}, ucfirst ($_);
+ print
+ td {-class => 'smallnumber'}, $stat;
+ print
+ td {-class => 'smallnumber'}, $percent;
+ print end_Tr;
+ } # foreach
+ print end_table;
+ print end_div;
+} # displayquickstats
+
+sub Footing (;$) {
+ my ($table_name) = @_;
+
+ # General footing (copyright). Note we calculate the current year
+ # so that the copyright automatically extends itself.
+ my $year = substr ((scalar (localtime)), 20, 4);
+
+ print start_div {-class => "copyright"};
+ print "Copyright © 2001-$year - All rights reserved";
+ print br (
+ a ({-href => 'http://defaria.com'},
+ 'Andrew DeFaria'),
+ a ({-href => 'mailto:Andrew@DeFaria.com'},
+ '<Andrew@DeFaria.com>'));
+ print end_div;
+
+ print end_div; # This div ends "content" which was started in Heading
+ print "<script language='JavaScript1.2'>AdjustTableWidth (\"$table_name\");</script>"
+ if $table_name;
+ print end_html;
+} # Footing
+
+sub Debug ($) {
+ my ($msg) = @_;
+
+ print br, font ({ -class => 'error' }, 'DEBUG: '), $msg;
+} # Debug
+
+sub DisplayError ($) {
+ my ($errmsg) = @_;
+
+ print h3 ({-class => 'error',
+ -align => 'center'}, 'ERROR: ' . $errmsg);
+
+ Footing;
+
+ exit 1;
+} # DisplayError
+
+# This subroutine puts out the header for web pages. It is called by
+# various cgi scripts thus has a few parameters.
+sub Heading ($$$$;$$@) {
+ my ($action, # One of getcookie, setcookie, unsetcookie
+ $userid, # User id (if setting a cookie)
+ $title, # Title string
+ $h1, # H1 header
+ $h2, # H2 header (optional)
+ $table_name, # Name of table in page, if any
+ @scripts) = @_; # Array of JavaScript scripts to include
+
+ my @java_scripts;
+ my $cookie;
+
+ # Since CheckAddress appears on all pages (well except for the login
+ # page) include it by default along with MAPSUtils.js
+ push @java_scripts, [
+ {-language => 'JavaScript1.2',
+ -src => '/maps/JavaScript/MAPSUtils.js'},
+ {-language => 'JavaScript1.2',
+ -src => '/maps/JavaScript/CheckAddress.js'}
+ ];
+
+ # Add on any additional JavaScripts that the caller wants. Note the
+ # odd single element array of hashes but that's what CGI requires!
+ # Build up scripts from array
+ foreach (@scripts) {
+ push @{$java_scripts[0]},
+ {-language => 'JavaScript1.2',
+ -src => "/maps/JavaScript/$_"}
+ } # foreach
+
+ # Since Heading is called from various scripts we sometimes need to
+ # set a cookie, other times delete a cookie but most times return the
+ # cookie.
+ if ($action eq 'getcookie') {
+ # Get userid from cookie
+ $userid = cookie ('MAPSUser');
+ } elsif ($action eq 'setcookie') {
+ $cookie = cookie (
+ -name => 'MAPSUser',
+ -value => $userid,
+ -expires => '+1y',
+ -path => '/maps'
+ );
+ } elsif ($action eq 'unsetcookie') {
+ $cookie = cookie (
+ -name => 'MAPSUser',
+ -value => '',
+ -expires => '-1d',
+ -path => '/maps'
+ );
+ } # if
+
+ print
+ header (-title => "MAPS: $title",
+ -cookie => $cookie);
+
+ if (defined $table_name) {
+ print
+ start_html (-title => "MAPS: $title",
+ -author => 'Andrew\@DeFaria.com',
+ -style => {-src => '/maps/css/MAPSStyle.css'},
+ -onResize => "AdjustTableWidth (\"$table_name\");",
+ -head => [
+ Link ({-rel => 'icon',
+ -href => '/maps/MAPS.png',
+ -type => 'image/png'}),
+ Link ({-rel => 'shortcut icon',
+ -href => '/maps/favicon.ico'})
+ ],
+ -script => @java_scripts);
+ } else {
+ print
+ start_html (-title => "MAPS: $title",
+ -author => 'Andrew\@DeFaria.com',
+ -style => {-src => '/maps/css/MAPSStyle.css'},
+ -head => [
+ Link ({-rel => 'icon',
+ -href => '/maps/MAPS.png',
+ -type => 'image/png'}),
+ Link ({-rel => 'shortcut icon',
+ -href => '/maps/favicon.ico'})],
+ -script => @java_scripts);
+ } # if
+
+ print start_div {class => 'heading'};
+ print h2 {-align => 'center',
+ -class => 'header'},
+ font ({-class => 'standout'}, 'MAPS'),
+ $h1;
+
+ if (defined $h2 && $h2 ne '') {
+ print h3 {-align => 'center',
+ -class => 'header'},
+ $h2;
+ } # if
+ print end_div;
+
+ # Start body content
+ print start_div {-class => 'content'};
+
+ return $userid
+} # Heading
+
+sub NavigationBar {
+ my $userid = shift;
+
+ print start_div {-id => 'leftbar'};
+
+ if (!defined $userid) {
+ print div ({-class => 'username'}, 'Welcome to MAPS');
+ print div ({-class => 'menu'},
+ (a {-href => '/maps/doc/'},
+ 'What is MAPS?<br>'),
+ (a {-href => '/maps/doc/SPAM.html'},
+ 'What is SPAM?<br>'),
+ (a {-href => '/maps/doc/Requirements.html'},
+ 'Requirements<br>'),
+ (a {-href => '/maps/SignupForm.html'},
+ 'Signup<br>'),
+ (a {-href => '/maps/doc/Using.html'},
+ 'Using MAPS<br>'),
+ (a {-href => '/maps/doc/'},
+ 'Help<br>'),
+ );
+ } else {
+ print div ({-class => 'username'}, 'Welcome '. ucfirst $userid);
+ print div ({-class => 'menu'},
+ (a {-href => '/maps/'},
+ 'MAPS Home<br>'),
+ (a {-href => '/maps/bin/stats.cgi'},
+ 'Statistics<br>'),
+ (a {-href => '/maps/bin/editprofile.cgi'},
+ 'Edit Profile<br>'),
+ (a {-href => '/maps/php/Reports.php'},
+ 'Reports<br>'),
+ (a {-href => '/maps/php/list.php?type=white'},
+ 'White List<br>'),
+ (a {-href => '/maps/php/list.php?type=black'},
+ 'Black List<br>'),
+ (a {-href => '/maps/php/list.php?type=null'},
+ 'Null List<br>'),
+ (a {-href => '/maps/doc/'},
+ 'Help<br>'),
+ (a {-href => '/maps/adm/'},
+ 'MAPS Admin<br>'),
+ (a {-href => '/maps/?logout=yes'},
+ 'Logout'),
+ );
+ print start_div {-class => 'search'};
+ print start_form {-method => 'get',
+ -action => '/maps/bin/search.cgi',
+ -name => 'search'};
+ print 'Search Sender/Subject',
+ textfield {-class => 'searchfield',
+ -id => 'searchfield',
+ -name => 'str',
+ -size => 20,
+ -maxlength => 255,
+ -value => '',
+ -onclick => "document.search.str.value = '';"};
+ print end_form;
+ print end_div;
+
+ displayquickstats;
+
+ print start_div {-class => 'search'};
+ print start_form {-method => 'post',
+ -action => 'javascript://',
+ -name => 'address',
+ -onsubmit => 'checkaddress(this);'};
+ print 'Check Email Address',
+ textfield {-class => 'searchfield',
+ -id => 'searchfield',
+ -name => 'email',
+ -size => 20,
+ -maxlength => 255,
+ -value => '',
+ -onclick => "document.address.email.value = '';"};
+ print end_form;
+ print end_div;
+ } # if
+
+ print end_div;
+} # NavigationBar
+
+1;
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: $RCSfile: add2blacklist.cgi,v $
+# Revision: $Revision: 1.1 $
+# Description: Add an email address to the blacklist
+# Author: Andrew@DeFaria.com
+# Created: Mon Jan 16 20:25:32 PST 2006
+# Modified: $Date: 2013/06/12 14:05:47 $
+# Language: Perl
+#
+# (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+use strict;
+use warnings;
+
+use FindBin;
+$0 = $FindBin::Script;
+
+use lib $FindBin::Bin;
+
+use MAPS;
+use MAPSLog;
+use MAPSWeb;
+
+use CGI qw/:standard *table/;
+use CGI::Carp 'fatalsToBrowser';
+
+my $userid;
+my $Userid;
+my $type = 'black';
+
+sub Add2List {
+ my $sender = '';
+ my $nextseq = MAPSDB::GetNextSequenceNo $userid, $type;
+
+ while () {
+ my $pattern = param "pattern$nextseq";
+ my $domain = param "domain$nextseq";
+ my $comment = param "comment$nextseq";
+
+ last if ((!defined $pattern || $pattern eq '') &&
+ (!defined $domain || $domain eq ''));
+
+ $sender = lc "$pattern\@$domain";
+
+ my ($status, $rule) = OnBlacklist $sender;
+
+ if ($status != 0) {
+ print br {-class => 'error'}, "The email address $sender is already on ${Userid}'s $type list";
+ } else {
+ Add2Blacklist $sender, $userid, $comment;
+ print br "The email address, $sender, has been added to ${Userid}'s $type list";
+
+ # Now remove this entry from the other lists (if present)
+ foreach my $otherlist ('white', 'null') {
+ my $sth = FindList $otherlist, $sender;
+ my ($sequence, $count);
+
+ ($_, $_, $_, $_, $_, $sequence) = GetList $sth;
+
+ if ($sequence) {
+ $count = DeleteList $otherlist, $sequence;
+ print br "Removed $sender from ${Userid}'s " . ucfirst $otherlist . ' list'
+ if $count > 0;
+
+ ResequenceList $userid, $otherlist;
+ } # if
+ } # foreach
+ } # if
+
+ $nextseq++;
+ } # while
+} # Add2List
+
+# Main
+$userid = Heading (
+ 'getcookie',
+ '',
+ 'Add to Black List',
+ 'Add to Black List',
+);
+
+$Userid = ucfirst $userid;
+
+SetContext $userid;
+
+NavigationBar $userid;
+
+Add2List;
+
+print start_form {
+ -method => 'post',
+ -action => 'processaction.cgi',
+ -name => 'list'
+};
+
+print '<p></p><center>',
+ hidden ({-name => 'type',
+ -default => $type}),
+ submit ({-name => 'action',
+ -value => 'Add New Entry'}),
+ '</center>';
+
+Footing;
+
+exit;
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: $RCSfile: add2nulllist.cgi,v $
+# Revision: $Revision: 1.1 $
+# Description: Add an email address to the nulllist
+# Author: Andrew@DeFaria.com
+# Created: Mon Jan 16 20:25:32 PST 2006
+# Modified: $Date: 2013/06/12 14:05:47 $
+# Language: Perl
+#
+# (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+use strict;
+use warnings;
+
+use FindBin;
+$0 = $FindBin::Script;
+
+use lib $FindBin::Bin;
+
+use MAPS;
+use MAPSLog;
+use MAPSWeb;
+
+use CGI qw/:standard *table/;
+use CGI::Carp 'fatalsToBrowser';
+
+my $userid;
+my $Userid;
+my $type = 'null';
+
+sub Add2List {
+ my $sender = '';
+ my $nextseq = MAPSDB::GetNextSequenceNo $userid, $type;
+
+ while () {
+ my $pattern = param "pattern$nextseq";
+ my $domain = param "domain$nextseq";
+ my $comment = param "comment$nextseq";
+
+ last if ((!defined $pattern || $pattern eq '') &&
+ (!defined $domain || $domain eq ''));
+
+ $sender = lc "$pattern\@$domain";
+
+ my ($status, $rule) = OnNulllist $sender;
+
+ if ($status != 0) {
+ print br {-class => 'error'}, "The email address $sender is already on ${Userid}'s $type list";
+ } else {
+ Add2Nulllist $sender, $userid, $comment;
+
+ print br "The email address, $sender, has been added to ${Userid}'s $type list";
+
+ # Now remove this entry from the other lists (if present)
+ foreach my $otherlist ('white', 'black') {
+ my $sth = FindList $otherlist, $sender;
+ my ($sequence, $count);
+
+ ($_, $_, $_, $_, $_, $sequence) = GetList $sth;
+
+ if ($sequence) {
+ $count = DeleteList $otherlist, $sequence;
+
+ print br "Removed $sender from ${Userid}'s " . ucfirst $otherlist . ' list'
+ if $count > 0;
+
+ ResequenceList $userid, $otherlist;
+ } # if
+ } # foreach
+ } # if
+
+ $nextseq++;
+ } # while
+} # Add2List
+
+# Main
+$userid = Heading (
+ 'getcookie',
+ '',
+ 'Add to Null List',
+ 'Add to Null List',
+);
+
+SetContext $userid;
+
+NavigationBar $userid;
+
+$Userid = ucfirst $userid;
+
+Add2List;
+
+print start_form {
+ -method => 'post',
+ -action => 'processaction.cgi',
+ -name => 'list'
+};
+
+print '<p></p><center>',
+ hidden ({-name => 'type',
+ -default => $type}),
+ submit ({-name => 'action',
+ -value => 'Add New Entry'}),
+ '</center>';
+
+Footing;
+
+exit;
--- /dev/null
+#!/usr/bin/perl
+use strict;
+use warnings;
+
+use FindBin;
+
+use lib $FindBin::Bin, '/opt/clearscm/lib';
+
+use MAPS;
+use MAPSLog;
+use MAPSWeb;
+use Display;
+
+# Highly specialized!
+my $userid = $ENV{USER};
+my $Userid;
+my $type = "null";
+
+sub GetItems {
+ my $filename = shift;
+
+ my @items;
+
+ open FILE, $filename
+ or error "Unable to open $filename - $!", 1;
+
+ while (<FILE>) {
+ my @fields = split;
+ my %item;
+
+ my @address = split /\@/, $fields [0];
+
+ $item {pattern} = $address [0];
+ $item {domain} = $address [1];
+ $item {comment} = $fields [1] ? $fields [1] : "";
+
+ push @items, \%item;
+ } # while
+
+ return @items;
+} # GetItems
+
+sub Add2List {
+ my @items = @_;
+
+ my $sender = "";
+ my $nextseq = MAPSDB::GetNextSequenceNo $userid, $type;
+
+ foreach (@items) {
+ my %item = %{$_};
+
+ my $pattern = $item {pattern};
+ my $domain = $item {domain};
+ my $comment = $item {comment};
+
+ display_nolf "Adding $pattern\@$domain ($comment) to null list ($nextseq)...";
+ last if ((!defined $pattern || $pattern eq "") &&
+ (!defined $domain || $domain eq ""));
+ $sender = lc ("$pattern\@$domain");
+
+ if (OnNulllist $sender) {
+ display " Already on list";
+ } else {
+ Add2Nulllist $sender, $userid, $comment;
+ display " done";
+
+ # Now remove this entry from the other lists (if present)
+ foreach my $otherlist ("white", "black") {
+ my $sth = FindList $otherlist, $sender;
+ my ($sequence, $count);
+ ($_, $_, $_, $_, $_, $sequence) = GetList $sth;
+ if (defined $sequence) {
+ $count = DeleteList $otherlist, $sequence;
+ } # if
+ } # foreach
+ } # if
+ $nextseq++;
+ } # while
+} # Add2List
+
+# Main
+my $filename;
+
+if ($ARGV [0]) {
+ $filename = $ARGV [0];
+} else {
+ error "Must specify a filename of addresses to null list", 1;
+} # if
+
+SetContext $userid;
+
+$Userid = ucfirst $userid;
+
+Add2List (GetItems $filename);
+
+exit;
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: $RCSfile: add2whitelist.cgi,v $
+# Revision: $Revision: 1.1 $
+# Description: Add an email address to the blacklist
+# Author: Andrew@DeFaria.com
+# Created: Mon Jan 16 20:25:32 PST 2006
+# Modified: $Date: 2013/06/12 14:05:47 $
+# Language: Perl
+#
+# (C) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+use strict;
+use warnings;
+
+use FindBin;
+$0 = $FindBin::Script;
+
+use lib $FindBin::Bin;
+
+use MAPS;
+use MAPSLog;
+use MAPSWeb;
+
+use CGI qw/:standard *table/;
+use CGI::Carp 'fatalsToBrowser';
+
+my $userid;
+my $Userid;
+my $type = 'white';
+
+sub Add2List {
+ my $sender = '';
+ my $nextseq = MAPSDB::GetNextSequenceNo $userid, $type;
+
+ while () {
+ my $pattern = param "pattern$nextseq";
+ my $domain = param "domain$nextseq";
+ my $comment = param "comment$nextseq";
+
+ last if ((!defined $pattern || $pattern eq '') &&
+ (!defined $domain || $domain eq ''));
+
+ $sender = lc "$pattern\@$domain";
+
+ my ($status, $rule) = OnWhitelist $sender, $userid;
+
+ if ($status != 0) {
+ print br {-class => 'error'}, "The email address $sender is already on ${Userid}'s $type list";
+ } else {
+ my $messages = Add2Whitelist $sender, $userid, $comment;
+
+ print br "The email address, $sender, has been added to ${Userid}'s $type list";
+ if ($messages > 0) {
+ if ($messages == 1) {
+ print br 'Your previous message has been delivered';
+ } else {
+ print br "Your previous $messages messages have been delivered";
+ } # if
+ } elsif ($messages == -1) {
+ print br {-class => 'error'}, 'Unable to deliver message';
+ } else {
+ print br 'Unable to find any old messages but future messages will now be delivered.';
+ } # if
+
+ # Now remove this entry from the other lists (if present)
+ foreach my $otherlist ('black', 'null') {
+ my $sth = FindList $otherlist, $sender;
+ my ($sequence, $count);
+
+ ($_, $_, $_, $_, $_, $sequence) = GetList $sth;
+
+ if ($sequence) {
+ $count = DeleteList $otherlist, $sequence;
+ print br "Removed $sender from ${Userid}'s " . ucfirst $otherlist . ' list'
+ if $count > 0;
+
+ ResequenceList $userid, $otherlist;
+ } # if
+ } # foreach
+ } # if
+
+ $nextseq++;
+ } # while
+} # Add2List
+
+# Main
+$userid = Heading (
+ 'getcookie',
+ '',
+ 'Add to White List',
+ 'Add to White List',
+);
+
+$userid ||= $ENV{USER};
+
+$Userid = ucfirst $userid;
+
+SetContext $userid;
+
+NavigationBar $userid;
+
+Add2List;
+
+print start_form {
+ -method => 'post',
+ -action => 'processaction.cgi',
+ -name => 'list'
+};
+
+print '<p></p><center>',
+ hidden ({-name => 'type',
+ -default => $type}),
+ submit ({-name => 'action',
+ -value => 'Add New Entry'}),
+ '</center>';
+
+Footing;
+
+exit;
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: $RCSfile: checkaddress,v $
+# Revision: $Revision: 1.1 $
+# Description: Check an email address
+# Author: Andrew@DeFaria.com
+# Created: Mon Jan 16 20:25:32 PST 2006
+# Modified: $Date: 2013/06/12 14:05:47 $
+# Language: perl
+#
+# (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+use strict;
+use warnings;
+
+use FindBin;
+
+use lib $FindBin::Bin, '/opt/clearscm/lib';
+
+use MAPS;
+use Display;
+
+error ("Must specify an email address to check", 1)
+ if !$ARGV[0] or $ARGV[0] eq "";
+
+foreach (@ARGV) {
+ my $sender = lc $_;
+
+ my ($status, $rule);
+
+ my $username = lc $ENV{USER};
+
+ my ($user, $domain) = $sender =~ /(.+)\@(.+)/;
+
+ unless ($user and $domain) {
+ error "Illegal email address $sender";
+
+ next;
+ } # unless
+
+ if ($domain eq "defaria.com" and $user ne $username) {
+ display "Nulllist - $sender is from this domain but is not from $username";
+ next;
+ } # if
+
+ ($status, $rule) = OnNulllist $sender;
+
+ if ($status) {
+ display "Sender $sender would be nulllist'ed\n$rule";
+ } else {
+ ($status, $rule) = OnBlacklist $sender;
+
+ if ($status) {
+ display "Sender $sender would be blacklist'ed\n$rule";
+ } else {
+ ($status, $rule) = OnWhitelist $sender;
+
+ if ($status) {
+ display "Sender $sender would be whitelist'ed\n$rule";
+ } else {
+ display "Sender $sender would be returned";
+ } # if
+ } # if
+ } # if
+} # foreach
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: $RCSfile: checkaddress.cgi,v $
+# Revision: $Revision: 1.1 $
+# Description: Check an email address
+# Author: Andrew@DeFaria.com
+# Created: Mon Jan 16 20:25:32 PST 2006
+# Modified: $Date: 2013/06/12 14:05:47 $
+# Language: perl
+#
+# (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+use strict;
+use warnings;
+
+use FindBin;
+$0 = $FindBin::Script;
+
+use lib $FindBin::Bin;
+
+use MAPS;
+
+use CGI qw (:standard);
+
+# Get MAPSUser from cookie
+my $userid;
+
+if (param "user") {
+ $userid = param "user";
+} else {
+ $userid = cookie ("MAPSUser");
+} # if
+
+my $sender = param ("sender");
+
+sub Heading {
+ print
+ header (-title => "MAPS: Check Address"),
+ start_html (-title => "MAPS: Check Address",
+ -author => "Andrew\@DeFaria.com");
+ print h3 {-align => "center",
+ -class => "header"},
+ "MAPS: Checking address $sender";
+} # Heading
+
+sub Body {
+ my ($status, $rule);
+
+ ($status, $rule) = OnNulllist $sender;
+ if ($status) {
+ print div {-align => "center"},
+ font {-color => "grey"},
+ "Messages from", b ($sender), "will be", b ("discarded"), br, hr;
+ print $rule;
+ } else {
+ ($status, $rule) = OnBlacklist $sender;
+ if ($status) {
+ print div {-align => "center"},
+ font {-color => "black"},
+ "Messages from", b ($sender), "will be", b ("blacklisted"), br, hr;
+ print $rule;
+ } else {
+ ($status, $rule) = OnWhitelist $sender;
+ if ($status) {
+ print div {-align => "center"},
+ font {-color => "green"},
+ "Messages from", b ($sender), "will be", b ("delivered"), br, hr;
+ print $rule;
+ } else {
+ print div {-align => "center"},
+ font {-color => "red"},
+ "Messages from", b ($sender), "will be", b ("returned");
+ } # if
+ } # if
+ } # if
+
+ print br div {-align => "center"},
+ submit (-name => "submit",
+ -value => "Close",
+ -onClick => "window.close (self)");
+} # Body
+
+sub Footing {
+ print end_html;
+} # Footing
+
+# Main
+SetContext $userid;
+Heading;
+Body;
+Footing;
+
+exit;
+
--- /dev/null
+#!/usr/bin/perl
+#################################################################################
+# File: $RCSfile: detail.cgi,v $
+# Revision: $Revision: 1.1 $
+# Description: Displays list of email addresses based on report type.
+# Author: Andrew@DeFaria.com
+# Created: Fri Nov 29 14:17:21 2002
+# Modified: $Date: 2013/06/12 14:05:47 $
+# Language: perl
+#
+# (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################use strict;
+use warnings;
+
+use MIME::Words qw(:all);
+use FindBin;
+$0 = $FindBin::Script;
+
+use lib $FindBin::Bin;
+
+use MAPS;
+use MAPSLog;
+use MAPSUtil;
+use MAPSWeb;
+use CGI qw (:standard *table start_td end_td start_Tr end_Tr start_div end_div);
+use CGI::Carp 'fatalsToBrowser';
+
+my $type = param ('type');
+my $next = param ('next');
+my $lines = param ('lines');
+my $date = param ('date');
+
+$date ||= '';
+
+my $userid;
+my $current;
+my $last;
+my $prev;
+my $total;
+my $table_name = 'detail';
+
+my %types = (
+ 'blacklist' => [
+ 'Blacklist report',
+ 'The following blacklisted users attempted to email you'
+ ],
+ 'whitelist' => [
+ 'Delivered report',
+ 'Delivered email from the following users'
+ ],
+ 'nulllist' => [
+ 'Discarded report',
+ 'Discarded messages from the following users'
+ ],
+ 'error' => [
+ 'Error report',
+ 'Errors detected'
+ ],
+ 'mailloop' => [
+ 'MailLoop report',
+ 'Automatically detected mail loops from the following users'
+ ],
+ 'registered' => [
+ 'Registered report',
+ 'The following users have recently registered'
+ ],
+ 'returned' => [
+ 'Returned report',
+ 'Sent Register reply to the following users'
+ ]
+);
+
+sub MakeButtons {
+ my $type = shift;
+
+ my $prev_button = $prev >= 0 ?
+ a ({-href => "detail.cgi?type=$type;date=$date;next=$prev"},
+ '<img src=/maps/images/previous.gif border=0 alt=Previous align=middle>') : '';
+ my $next_button = ($next + $lines) < $total ?
+ a {-href => "detail.cgi?type=$type;date=$date;next=" . ($next + $lines)},
+ '<img src=/maps/images/next.gif border=0 alt=Next align=middle>' : '';
+
+ my $buttons = $prev_button;
+
+ if ($type eq 'whitelist') {
+ $buttons = $buttons .
+ submit ({-name => 'action',
+ -value => 'Blacklist Marked',
+ -onClick => 'return CheckAtLeast1Checked (document.detail);'}) .
+ submit ({-name => 'action',
+ -value => 'Nulllist Marked',
+ -onClick => 'return CheckAtLeast1Checked (document.detail);'}) .
+ submit ({-name => 'action',
+ -value => 'Reset Marks',
+ -onClick => 'return ClearAll (document.detail);'});
+ } elsif ($type eq 'blacklist') {
+ $buttons = $buttons .
+ submit ({-name => 'action',
+ -value => 'Whitelist Marked',
+ -onClick => 'return CheckAtLeast1Checked (document.detail);'}) .
+ submit ({-name => 'action',
+ -value => 'Nulllist Marked',
+ -onClick => 'return CheckAtLeast1Checked (document.detail);'}) .
+ submit ({-name => 'action',
+ -value => 'Reset Marks',
+ -onClick => 'return ClearAll (document.detail);'});
+ } elsif ($type eq 'nulllist') {
+ $buttons = $buttons .
+ submit ({-name => 'action',
+ -value => 'Whitelist Marked',
+ -onClick => 'return CheckAtLeast1Checked (document.detail);'}) .
+ submit ({-name => 'action',
+ -value => 'Blacklist Marked',
+ -onClick => 'return CheckAtLeast1Checked (document.detail);'}) .
+ submit ({-name => 'action',
+ -value => 'Reset Marks',
+ -onClick => 'return ClearAll (document.detail);'});
+ } else {
+ $buttons = $buttons .
+ submit ({-name => 'action',
+ -value => 'Whitelist Marked',
+ -onClick => 'return CheckAtLeast1Checked (document.detail);'}) .
+ submit ({-name => 'action',
+ -value => 'Blacklist Marked',
+ -onClick => 'return CheckAtLeast1Checked (document.detail);'}) .
+ submit ({-name => 'action',
+ -value => 'Nulllist Marked',
+ -onClick => 'return CheckAtLeast1Checked (document.detail);'}) .
+ submit ({-name => 'action',
+ -value => 'Reset Marks',
+ -onClick => 'return ClearAll (document.detail);'});
+ } # if
+
+ return $buttons . $next_button;
+} # MakeButtons
+
+sub PrintTable {
+ my ($type) = @_;
+
+ my $current = $next + 1;
+
+ print div {-align => 'center'}, b (
+ '(' . $current . '-' . $last . ' of ' . $total . ')');
+ print start_form {
+ -method => 'post',
+ -action => 'processaction.cgi',
+ -name => 'detail'
+ };
+ print start_table ({-align => 'center',
+ -id => $table_name,
+ -border => 0,
+ -cellspacing => 0,
+ -cellpadding => 0,
+ -width => '100%'}) . "\n";
+
+ my $buttons = MakeButtons $type;
+
+ print start_div {-class => 'toolbar'};
+ print
+ Tr [
+ td {-class => 'tablebordertopleft',
+ -valign => 'middle'},
+ td {-class => 'tablebordertopright',
+ -valign => 'middle',
+ -align => 'center'}, $buttons,
+ ];
+ print end_div;
+
+ foreach my $sender (ReturnSenders $userid, $type, $next, $lines, $date) {
+ my @msgs = ReturnMessages $userid, $sender;
+
+ $next++;
+ print
+ start_Tr {-valign => 'middle'};
+ print
+ td {-class => 'tableborder'}, small ($next,
+ checkbox {-name => "action$next",
+ -label => ''}),
+ hidden ({-name => "email$next",
+ -default => $sender});
+ print
+ start_td {-align => 'left'};
+ print
+ start_table {-class => 'tablerightdata',
+ -cellpadding => 2,
+ -callspacing => 0,
+ -border => 0,
+ -width => '100%',
+ -bgcolor => '#d4d0c8'};
+ print
+ td {-class => 'tablelabel',
+ -valign => 'middle',
+ -width => '40'}, 'Sender:',
+ td {-class => 'sender',
+ -valign => 'middle'},
+ a {-href => "mailto:$sender"}, $sender;
+ print
+ end_table;
+
+ my $messages = 1;
+
+ foreach (@msgs) {
+ my $msg_date = pop @{$_};
+ my $subject = pop @{$_};
+
+ if ($date eq substr ($msg_date, 0, 10)) {
+ $msg_date = b font {-color => 'green'}, SQLDatetime2UnixDatetime $msg_date;
+ } else {
+ $msg_date = SQLDatetime2UnixDatetime $msg_date;
+ } # if
+
+ $subject = $subject eq '' ? '<Unspecified>' : $subject;
+ $subject = decode_mimewords ($subject);
+ $subject =~ s/\>/>/g;
+ $subject =~ s/\</</g;
+
+ print
+ start_table {-class => 'tablerightdata',
+ -cellpadding => 2,
+ -cellspacing => 2,
+ -border => 0,
+ -width => '100%'};
+ my $msg_nbr = $messages;
+ print
+ Tr [
+ td {-class => 'msgnbr',
+ -valign => 'middle',
+ -rowspan => 2,
+ -width => '2%'}, $messages++,
+ td {-class => 'tablelabel',
+ -valign => 'middle',
+ -width => '45'}, 'Subject:',
+ td {-class => 'subject',
+ -valign => 'middle',
+ -bgcolor => '#ffffff'},
+ a {-href => "display.cgi?sender=$sender;msg_nbr=$msg_nbr"}, $subject,
+ td {-class => 'date',
+ -width => '130',
+ -valign => 'middle'}, $msg_date
+ ];
+ print end_table;
+ } # foreach
+ print end_td;
+ print end_Tr;
+ } # foreach
+
+ print start_div {-class => 'toolbar'};
+ print
+ Tr [
+ td {-class => 'tableborderbottomleft',
+ -valign => 'middle'},
+ td {-class => 'tableborderbottomright',
+ -valign => 'middle'},
+ $buttons
+ ];
+ print end_div;
+ print end_table;
+ print end_form;
+} # PrintTable
+
+# Main
+my @scripts = ('ListActions.js');
+
+my $heading_date =$date ne '' ? ' on ' . FormatDate ($date) : '';
+
+$userid = Heading (
+ 'getcookie',
+ '',
+ (ucfirst ($type) . ' Report'),
+ $types {$type} [0],
+ $types {$type} [1] . $heading_date,
+ $table_name,
+ @scripts
+);
+
+$userid ||= $ENV{USER};
+
+SetContext $userid;
+NavigationBar $userid;
+
+unless ($lines) {
+ my %options = GetUserOptions $userid;
+ $lines = $options{'Page'};
+} # unless
+
+if ($date eq '') {
+ $condition .= "userid = '$userid' and type = '$type'";
+} else {
+ my $sod = $date . ' 00:00:00';
+ my $eod = $date . ' 23:59:59';
+
+ $condition .= "userid = '$userid' and type = '$type' "
+ . "and timestamp > '$sod' and timestamp < '$eod' ";
+} # if
+
+$total = MAPSDB::count_distinct ('log', 'sender', $condition);
+
+$next ||= 0;
+
+$last = $next + $lines < $total ? $next + $lines : $total;
+
+if (($next - $lines) > 0) {
+ $prev = $next - $lines;
+} else {
+ $prev = $next eq 0 ? -1 : 0;
+} # if
+
+PrintTable $type;
+
+Footing $table_name;
+
+exit;
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: $RCSfile: display.cgi,v $
+# Revision: $Revision: 1.1 $
+# Description: Displays an email message
+# Author: Andrew@DeFaria.com
+# Created: Fri Nov 29 14:17:21 2002
+# Modified: $Date: 2013/06/12 14:05:47 $
+# Language: perl
+#
+# (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+use strict;
+use warnings;
+
+use FindBin;
+$0 = $FindBin::Script;
+
+use lib $FindBin::Bin;
+
+use MAPS;
+use MAPSWeb;
+
+use CGI qw/:standard *table/;
+use CGI::Carp "fatalsToBrowser";
+
+use MIME::Parser;
+use MIME::Base64;
+use MIME::Words qw(:all);
+
+my $userid = cookie ("MAPSUser");
+my $sender = param ("sender");
+my $msg_nbr = param ("msg_nbr");
+my $table_name = "message";
+
+sub ParseEmail (@) {
+ my (@header) = @_;
+
+ my %header;
+
+ # First output the header information. Note we'll skip uninteresting stuff
+ foreach (@header) {
+ last if ($_ eq "" || $_ eq "\cM");
+
+ # Escape "<" and ">"
+ s/\</\<\;/;
+ s/\>/\>\;/;
+
+ if (/^from:\s*(.*)/i) {
+ $header{From} = $1;
+ } elsif (/^subject:\s*(.*)/i) {
+ $header{Subject} = $1;
+ } elsif (/^date:\s*(.*)/i) {
+ $header{date} = $1;
+ } elsif (/^To:\s*(.*)/i) {
+ $header{to} = $1;
+ } # if
+ } # while
+
+ return %header;
+} # ParseEmail
+
+sub Body ($) {
+ my ($count) = @_;
+
+ $count ||= 1;
+
+ my $handle = FindEmail $sender;
+
+ my ($userid, $sender, $subject, $timestamp, $message);
+
+ # Need to handle multiple messages
+ for (my $i = 0; $i < $count; $i++) {
+ ($userid, $sender, $subject, $timestamp, $message) = GetEmail $handle;
+ } # for
+
+ my $parser = new MIME::Parser;
+
+ $parser->output_to_core (1);
+
+ my $entity = $parser->parse_data ($message);
+
+ my %header = ParseEmail @{($entity->header)[0]};
+
+ print p . "\n";
+ print start_table ({-align => "center",
+ -id => $table_name,
+ -border => 0,
+ -cellspacing => 0,
+ -cellpadding => 0,
+ -width => "100%"});
+ print start_table ({-align => "center",
+ -bgcolor => "#d4d0c8",
+ -border => 0,
+ -cellspacing => 2,
+ -cellpadding => 2,
+ -width => "100%"}) . "\n";
+ print "<tbody><tr><td>\n";
+ print start_table ({-align => "center",
+ -border => 0,
+ -cellspacing => 0,
+ -cellpadding => 2,
+ -bgcolor => "#ece9d8",
+ -width => "100%"}) . "\n";
+
+ foreach (keys (%header)) {
+ my $str = decode_mimewords ($header{$_});
+
+ print Tr ([
+ th ({-align => "right",
+ -bgcolor => "#ece9d8",
+ -width => "8%"}, "$_:") . "\n" .
+ td ({-bgcolor => "white"}, $str)
+ ]);
+ } # if
+
+ print end_table;
+ print "</td></tr>";
+ print end_table;
+
+ print start_table ({-align => "center",
+ -bgcolor => "black",
+ -border => 0,
+ -cellspacing => 0,
+ -cellpadding => 2,
+ -width => "100%"}) . "\n";
+ print "<tbody><tr><td>\n";
+ print start_table ({-align => "center",
+ -border => 0,
+ -cellspacing => 0,
+ -cellpadding => 2,
+ -bgcolor => "white",
+ -width => "100%"}) . "\n";
+ print "<tbody><tr><td>\n";
+
+ my @parts = $entity->parts;
+
+ if (scalar @parts == 0) {
+ print '<pre>';
+ $entity->print_body;
+ print '</pre>';
+ } else {
+ foreach my $part ($entity->parts) {
+ # We assume here that if this part is multipart/alternative then
+ # there exists at least one part that is text/html and we favor
+ # that (since we're outputing to a web page anyway...
+ if ($part->mime_type eq 'multipart/alternative') {
+ foreach my $subpart ($part->parts) {
+ if ($subpart->mime_type eq 'text/html') {
+ $subpart->print_body;
+ last;
+ } elsif ($subpart->mime_type eq 'multipart/related') {
+ # This is stupid - multipart/related? When it's really just HTML?!?
+ $subpart->print_body;
+ last;
+ } # if
+ } # foreach
+ } else {
+ if ($part->mime_type =~ /text/) {
+ print '<pre>';
+ $part->print_body;
+ print '</pre>';
+ } # if
+ } # if
+ } # foreach
+ } # if
+
+ print "</td></tr>\n";
+ print end_table;
+ print "</td></tr>\n";
+ print end_table;
+ print end_table;
+} # Body
+
+$userid = Heading (
+ "getcookie",
+ "",
+ "Email message from $sender",
+ "Email message from $sender",
+ "",
+ $table_name,
+);
+
+SetContext $userid;
+NavigationBar $userid;
+
+Body $msg_nbr;
+
+Footing $table_name;
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: $RCSfile: domains,v $
+# Revision: $Revision: 1.1 $
+# Description: Display entries from the list table where there is at least one
+# entry with a null pattern (nuke the domain) and yet still other
+# entries with the same domain name but having a pattern. We may
+# want to eliminate the other entries since we're nuking the
+# whole domain anyway.
+# Author: Andrew@DeFaria.com
+# Created: Sat Oct 20 23:28:19 MST 2007
+# Modified: $Date: 2013/06/12 14:05:47 $
+# Language: Perl
+#
+# (c) Copyright 2007, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+use strict;
+use warnings;
+
+use FindBin;
+use Getopt::Long;
+
+use lib $FindBin::Bin, '/opt/clearscm/lib';
+
+use MAPS;
+use MAPSDB;
+
+use Display;
+
+sub Usage () {
+ display <<END;
+$FindBin::Script { -verbose } { -debug } { -usage }
+END
+
+ exit 1;
+} # Usage
+
+GetOptions (
+ "verbose" => sub { set_verbose },
+ "debug" => sub { set_debug },
+ "usage" => sub { Usage },
+) || Usage;
+
+my $userid = $ENV{MAPS_USERNAME} ? $ENV{MAPS_USERNAME} : $ENV{USER};
+
+# Main
+SetContext $userid;
+
+my $statement = "select domain from list where userid=\"$userid\" and type=\"null\" and pattern is null";
+
+my $need_requence = 0;
+
+foreach my $domain (sort (&MAPSDB::GetRows ($statement))) {
+ verbose "Processing domain $domain";
+ $statement = "select sequence from list where userid = \"$userid\" and domain = \"$domain\" and type = \"null\" and pattern is not null";
+
+ foreach my $sequence (MAPSDB::GetRows $statement) {
+ display "Deleting $domain ($sequence)";
+ $need_requence = 1;
+ DeleteList "null", $sequence;
+ } # foreach
+} # foreach
+
+if ($need_requence) {
+ verbose "Resequencing null list...";
+ ResequenceList $userid, "null";
+ verbose "done";
+} # if
+
+exit;
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: $RCSfile: editprofile.cgi,v $
+# Revision: $Revision: 1.1 $
+# Description: Edit the user's profile
+# Author: Andrew@DeFaria.com
+# Created: Mon Jan 16 20:25:32 PST 2006
+# Modified: $Date: 2013/06/12 14:05:47 $
+# Language: perl
+#
+# (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+use strict;
+use warnings;
+
+use FindBin;
+$0 = $FindBin::Script;
+
+use lib $FindBin::Bin;
+
+use MAPS;
+use MAPSWeb;
+
+use CGI qw (:standard *table);
+
+my $userid;
+my $table_name = "profile";
+
+sub Body {
+ my $handle = FindUser $userid;
+
+ my ($fullname, $email, $password);
+ ($_, $fullname, $email, $password) = GetUser ($handle);
+
+ $handle->finish;
+
+ my %options = GetUserOptions $userid;
+
+ print start_form {
+ -method => "post",
+ -action => "updateprofile.cgi",
+ -onSubmit => "return validate (this);"
+ };
+ print start_table {
+ -align => "center",
+ -id => $table_name,
+ -border => 1,
+ -cellspacing => 0,
+ -cellpadding => 2,
+ -width => "100%"};
+ print Tr ([
+ td {-class => "label",
+ -width => 134},
+ "Username:",
+ td {-width => 290},
+ $userid,
+ td {-class => "notetext"},
+ "Specify a username to log into MAPS"
+ ]) . "\n";
+ print Tr ([
+ td {-class => "label"},
+ "Full name:",
+ td (
+ textfield {-class => "inputfield",
+ -size => 50,
+ -name => "fullname",
+ -value => "$fullname"}),
+ td {-class => "notetext"},
+ "Specify your full name"
+ ]) . "\n";
+ print Tr [
+ td {-class => "label"},
+ "Email:",
+ td (
+ textfield {-class => "inputfield",
+ -size => 50,
+ -name => "email",
+ -value => $email}),
+ td {-class => "notetext"},
+ "Your email address is used if you are a " .
+ i ("Tag & Forward") .
+ " user. This is the email address that MAPS will forward your email to after it tags it. This email address is also used in case you forget your password so that we can email you your password."
+ ];
+ print Tr [
+ td {-class => "label"},
+ "Old Password:",
+ td (
+ password_field {-class => "inputfield",
+ -size => 20,
+ -name => "old_password"}),
+ td {-class => "notetext"},
+ "Enter your old password"
+ ];
+ print Tr [
+ td {-class => "label"},
+ "New Password:",
+ td (
+ password_field {-class => "inputfield",
+ -size => 20,
+ -name => "new_password",
+ -value => ""}),
+ td {-class => "notetext"},
+ "Choose a new password greater than 6 characters."
+ ];
+ print Tr [
+ td {-class => "label"},
+ "Repeat Password:",
+ td (
+ password_field {-class => "inputfield",
+ -size => 20,
+ -name => "repeated_password",
+ -value => ""}),
+ td {-class => "notetext"},
+ "Re-enter your password so we can be sure you typed it correctly."
+ ];
+ print Tr [
+ td {-class => "label"},
+ "MAPSPOP user:",
+ td (
+ font ({-class => "label"},
+ radio_group {-name => "MAPSPOP",
+ -values => ["yes", "no"],
+ -default => "no",
+ -labels => {"yes" => "Yes",
+ "no" => "No"}})),
+ td {-class => "notetext"},
+ "MAPSPOP users need to download " .
+ a ({-href => "/maps/bin/MAPSPOP.exe"}, "MAPSPOP") .
+ ". See " .
+ a ({-href => "/maps/doc/UsingMAPSPOP.html"}, "Using MAPSPOP") .
+ " for more information."
+ ];
+ print Tr [
+ td {-class => "label"},
+ "Keep history for:",
+ td (
+ font ({-class => "label"},
+ popup_menu {-class => "inputfield",
+ -name => "history",
+ -values => ["7", "14", "30", "60", "90"],
+ -default => $options{"History"}}),
+ font ({-class => "label"}, " days")),
+ td {-class => "notetext"},
+ "This specifies how many days of history that MAPS will keep before discarding returned messages."
+ ];
+ print Tr [
+ td {-class => "label"},
+ "Dates in Stats Page:",
+ td (
+ font ({-class => "label"},
+ popup_menu {-class => "inputfield",
+ -name => "dates",
+ -values => ["7", "14", "21", "30"],
+ -default => $options{"Dates"}})),
+ td {-class => "notetext"},
+ "This specifies how many days are displayed in the MAPS Stats Page."
+ ];
+ print Tr [
+ td {-class => "label"},
+ "Entries per page:",
+ td (
+ font ({-class => "label"},
+ popup_menu {-class => "inputfield",
+ -name => "days",
+ -values => ["10", "20", "30", "40", "50"],
+ -default => $options{"Page"}})),
+ td {-class => "notetext"},
+ "This specifies how many entries are displayed per page in the online MAPS Reports."
+ ];
+ print Tr [
+ td {-class => "label"},
+ i ("Tag & Forward:"),
+ td (
+ font ({-class => "label"},
+ radio_group {-name => "tag_and_forward",
+ -values => ["yes", "no"],
+ -default => "no",
+ -labels => {"yes" => "Yes",
+ "no" => "No"}})),
+ td {-class => "notetext"},
+ i ("Tag and Forward") .
+ " means that MAPS will not filter or save any email for you. Instead it will simply add an X-MAPS header to your email indicating what MAPS would have done with the email. This allows you to filter your email in your local email client."
+ ];
+ print end_table;
+ print br (div {-align => "center"},
+ submit (-name => "submit",
+ -value => "Update Profile"));
+ print end_form;
+} # Body
+
+# Main
+my @scripts = ("MAPSUtils.js", "CheckEditProfile.js");
+
+$userid = Heading (
+ "getcookie",
+ "",
+ "Edit Profile",
+ "Spam Elimination System",
+ "",
+ $table_name,
+ @scripts
+);
+
+SetContext $userid;
+NavigationBar $userid;
+
+Body;
+
+Footing $table_name;
+
+exit;
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: $RCSfile: exportlist.cgi,v $
+# Revision: $Revision: 1.1 $
+# Description: Export an address list
+# Author: Andrew@DeFaria.com
+# Created: Mon Jan 16 20:25:32 PST 2006
+# Modified: $Date: 2013/06/12 14:05:47 $
+# Language: perl
+#
+# (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+use strict;
+
+use FindBin;
+$0 = $FindBin::Script;
+
+use lib $FindBin::Bin;
+
+use MAPS;
+use MAPSWeb;
+
+use CGI qw/:standard *table/;
+use CGI::Carp "fatalsToBrowser";
+
+my $type = param ("type");
+my $userid = cookie ("MAPSUser");
+my $Userid = ucfirst $userid;
+
+sub PrintList {
+ my $type = shift;
+
+ my $year = substr ((scalar (localtime)), 20, 4);
+
+ my ($pattern, $domain, $comment, $hit_count, $last_hit);
+ my $sth = FindList $type;
+
+ print "\################################################################################\n";
+ print "\#\n";
+ print "\# MAPS:\t\tMail Authorization and Permission System (MAPS)\n";
+ print "\# $type.list:\t${Userid}'s $type.list file\n";
+ print "\# Exported:\t" . localtime . "\n";
+ print "\#\n";
+ print "\# Copyright 2001-" . $year . ", Andrew\@DeFaria.com, all rights reserved.\n";
+ print "\#\n";
+ print "\################################################################################\n";
+
+ while (($_, $_, $pattern, $domain, $comment, $_, $hit_count, $last_hit) = GetList $sth) {
+ last if !(defined $pattern or defined $domain);
+ $pattern = !defined $pattern ? "" : $pattern;
+ $domain = !defined $domain ? "" : $domain;
+ if ($domain eq "") {
+ print "$pattern,$comment,$hit_count,$last_hit\n";
+ } else {
+ print "$pattern\@$domain,$comment,$hit_count,$last_hit\n";
+ } # if
+ } # while
+} # PrintList
+
+# Main
+SetContext $userid;
+
+print header (-type => "application/octet-stream",
+ -attachment => "$type.list");
+PrintList $type;
+exit;
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: $RCSfile: list.cgi,v $
+# Revision: $Revision: 1.1 $
+# Description: Manage lists
+# Author: Andrew@DeFaria.com
+# Created: Mon Jan 16 20:25:32 PST 2006
+# Modified: $Date: 2013/06/12 14:05:47 $
+# Language: perl
+#
+# (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+use strict;
+use warnings;
+
+use FindBin;
+$0 = $FindBin::Script;
+
+use lib $FindBin::Bin;
+
+use MAPS;
+use MAPSLog;
+use MAPSUtil;
+use MAPSWeb;
+use CGI qw (:standard *table start_div end_div);
+use CGI::Carp "fatalsToBrowser";
+
+my $next = param ("next");
+my $lines = param ("lines");
+my $type = param ("type");
+my $message = param ("message");
+my $Type = ucfirst $type;
+my $userid;
+my $prev;
+my $total;
+my $last;
+my $table_name = "list";
+
+sub Body {
+ my $type = shift;
+
+ if (defined $message) {
+ print div {-align => "center"},
+ font {-class => "error"}, $message;
+ } # if
+
+ print start_form {
+ -method => "post",
+ -action => "processaction.cgi",
+ -name => "list"
+ };
+
+ # Print some hidden fields to pass along
+ print
+ hidden (-name => "type",
+ -default => $type),
+ hidden (-name => "next",
+ -default => $next);
+
+ my $current = $next + 1;
+
+ print div {-align => "center"}, b (
+ "(" . $current . "-" . $last . " of " . $total . ")");
+ print start_div {-class => "toolbar",
+ -align => "center"};
+ my $prev_button = $prev >= 0 ?
+ a ({-href => "list.cgi?type=$type;next=$prev"},
+ "<img src=/maps/images/previous.gif border=0 alt=Previous align=middle>") : "";
+ my $next_button = ($next + $lines) < $total ?
+ a {-href => "list.cgi?type=$type;next=" . ($next + $lines)},
+ "<img src=/maps/images/next.gif border=0 alt=Next align=middle>" : "";
+ print $prev_button,
+ submit ({-name => "action",
+ -value => "Add New Entry",
+ -onClick => "return NoneChecked (document.list);"}),
+ submit ({-name => "action",
+ -value => "Delete Marked",
+ -onClick => "return CheckAtLeast1Checked (document.list) && AreYouSure ('Are you sure you want to delete these entries?');"}),
+ submit ({-name => "action",
+ -value => "Modify Marked",
+ -onClick => "return CheckAtLeast1Checked (document.list);"}),
+ submit ({-name => "action",
+ -value => "Reset Marks",
+ -onClick => "return ClearAll (document.list);"}),
+ $next_button;
+ print end_div;
+ print start_table {-align => "center",
+ -id => $table_name,
+ -border => 0,
+ -cellspacing => 0,
+ -cellpadding => 4,
+ -width => "100%"};
+ print Tr [
+ th {-class => "tableleftend"}, "Seq",
+ th {-class => "tableheader"}, "Mark",
+ th {-class => "tableheader"}, "Username",
+ th {-class => "tableheader"}, "@",
+ th {-class => "tableheader"}, "Domain",
+ th {-class => "tablerightend"}, "Comments"
+ ];
+
+ my @list = ReturnList $type, $next, $lines;
+ my %record;
+ my $i = 1;
+
+ foreach (@list) {
+ %record = %{$_};
+ $record{pattern} = " " if !defined $record{pattern};
+ $record{domain} = " " if !defined $record{domain};
+ $record{comment} = " " if !defined $record{comment};
+
+ my $leftclass = ($i eq $lines || $record{sequence} eq $total) ?
+ "tablebottomleft" : "tableleftdata";
+ my $dataclass = ($i eq $lines || $record{sequence} eq $total) ?
+ "tablebottomdata" : "tabledata";
+ my $rightclass = ($i eq $lines || $record{sequence} eq $total) ?
+ "tablebottomright" : "tablerightdata";
+ $i++;
+
+ print Tr [
+ td {-class => $leftclass,
+ -align => "center"}, $record{sequence},
+ td {-class => $dataclass,
+ -align => "center"},
+ checkbox ({-name => "action$record{sequence}",
+ -label => ""}),
+ td {-class => $dataclass,
+ -align => "right"}, $record{pattern},
+ td {-class => $dataclass,
+ -align => "center"}, "\@",
+ td {-class => $dataclass,
+ -align => "left"}, $record{domain},
+ td {-class => $rightclass,
+ -align => "left"}, $record{comment}
+ ];
+ } # foreach
+ print end_table;
+ print end_form;
+
+ print div ({-align => "center"},
+ a ({-href => "/maps/bin/exportlist.cgi?type=$type"},
+ submit ({-name => "export",
+ -value => "Export list"})),
+ a ({-href => "/maps/bin/importlist.cgi?type=$type"},
+ submit ({-name => "import",
+ -value => "Import List"})));
+} # Body
+
+# Main
+my @scripts = ("ListActions.js");
+
+$userid = Heading (
+ "getcookie",
+ "",
+ "Manage $Type List",
+ "Manage $Type List",
+ "",
+ $table_name,
+ @scripts
+);
+
+SetContext $userid;
+NavigationBar $userid;
+
+if (!defined $lines) {
+ my %options = GetUserOptions $userid;
+ $lines = $options{"Page"};
+} # if
+
+$total = MAPSDB::count "list", "userid = \"$userid\" and type = \"$type\"";;
+
+$next = !defined $next ? 0 : $next;
+$last = $next + $lines < $total ? $next + $lines : $total;
+
+if (($next - $lines) > 0) {
+ $prev = $next - $lines;
+} else {
+ $prev = $next eq 0 ? -1 : 0;
+} # if
+
+Body $type;
+Footing $table_name;
+
+exit;
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: $RCSfile: main.cgi,v $
+# Revision: $Revision: 1.1 $
+# Description: This is the main or home page for maps. It is presented when the
+# user logs in.
+# Author: Andrew@DeFaria.com
+# Created: Fri Nov 29 14:17:21 2002
+# Modified: $Date: 2013/06/12 14:05:47 $
+# Language: perl
+#
+# (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+use strict;
+use warnings;
+
+use FindBin;
+$0 = $FindBin::Script;
+
+use lib $FindBin::Bin;
+
+use MAPS;
+use MAPSLog;
+use MAPSUtil;
+use MAPSWeb;
+
+use CGI qw (:standard *table start_Tr end_Tr start_div end_div);
+use CGI::Carp "fatalsToBrowser";
+
+my $new_userid = param ("userid");
+my $password = param ("password");
+
+sub Body {
+ print
+ h3 ("Welcome to MAPS!"),
+ p "This is the main or home page of MAPS. To the left
+ you see a menu of choices that you can use to explore MAPS
+ functionality.",
+ a ({-href => "/maps/bin/stats.cgi"},
+ "Statistics"),
+ "gives you a view of the spam that MAPS has been trapping for you
+ in tabular format. You can use",
+ a ({-href => "/maps/bin/editprofile.cgi"},
+ "Edit Profile"),
+ "to change your profile information or to change your password.";
+ print
+ p "MAPS also offers a series of web based",
+ a ({-href => "/maps/Reports.html"},
+ "Reports"),
+ "to analyze your mail flow. You can manage your",
+ a ({-href => "/maps/bin/list.cgi?type=white"},
+ "White") . ",",
+ a ({-href => "/maps/bin/list.cgi?type=black"},
+ "Black"), "and",
+ a ({-href => "/maps/bin/list.cgi?type=null"},
+ "Null"),
+ "lists although MAPS seeks to put that responsibility on those
+ who wish to email you. You can use this to pre-register somebody
+ or to black or null list somebody. You can also import/export
+ your lists through these pages.";
+ print
+ p a ({-href => "/maps/Admin.html"},
+ "MAPS Administration"),
+ "is to administer MAPS itself and is only available to MAPS
+ Administrators.";
+ print
+ p "Also on the left you will see ", i ("Today's Activity"),
+ "which quickly shows you what mail MAPS processed today for you.";
+} # Body
+
+# Main
+my $action;
+
+if (defined $new_userid) {
+ my $result = Login $new_userid, $password;
+
+ if ($result == -1) {
+ if ($new_userid eq "") {
+ print redirect ("/maps/?errormsg=Please specify a username");
+ exit $result;
+ } else {
+ print redirect ("/maps/?errormsg=User \"$new_userid\" does not exist");
+ exit $result;
+ } # if
+ } elsif ($result == -2) {
+ print redirect ("/maps/?errormsg=Invalid password");
+ exit $result;
+ } else {
+ $action = "setcookie";
+ } # if
+} else {
+ $action = "getcookie"
+} # if
+
+my $userid = Heading (
+ $action,
+ $new_userid,
+ "Home",
+ "Spam Elimination System"
+);
+
+SetContext $userid;
+NavigationBar $userid;
+Body;
+Footing;
+
+exit;
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: maps,v $
+
+This script filters mail based on the files nulllist, blacklist and whitelist.
+Input is an email message. This script extracts the From line and then parses
+the email address. If the email is from a sender who should be /dev/null'ed
+(e.g. bounce messages from mail daemons) the message will be discarded. If the
+sender is on the blacklist then a message is sent back informing the sender that
+he's been blacklisted. If the sender is on the white list then the email is
+appended to the mail drop file. Otherwise a message is sent back informing the
+sender that in order to successfully send email the sender must register for the
+permission to do so, along with a URL that allows the sender to sign up.
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@DeFaria.com>
+
+=item Revision
+
+$Revision: 1.1 $
+
+=item Created:
+
+Fri Nov 29 14:17:21 2002
+
+=item Modified:
+
+$Date: 2013/06/12 14:05:47 $
+
+=back
+
+=head1 SYNOPSIS
+
+
+ Usage maps: [-u|ser <username>] [-ve|rbose] [-deb|ug] [-e|xecute]
+
+ Where:
+ -u|ser <username>: Set context to this username
+
+ -v|erbose: Be verbose
+ -de|bug: Output debug messages
+
+ -[no]e|xecute: Set execute mode.
+
+# (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
+
+=cut
+
+use strict;
+use warnings;
+
+use Getopt::Long;
+use FindBin;
+use File::Temp qw (tempfile);
+use Net::Domain qw (hostdomain);
+
+use lib $FindBin::Bin, '/opt/clearscm/lib';
+
+use MAPS;
+use MAPSLog;
+
+use Display;
+use Utils;
+
+my $verbose = 0;
+my $execute = 1;
+my $userid = $ENV{USER};
+
+my $logpath = "$FindBin::Bin/../log";
+my $logfile = "$logpath/debug.log";
+
+# For some reason I'm not parsing messages correctly but it only seems to
+# happen when the message is piped in from the MTA. This routine will
+# temporarily save the messages in a file.
+sub SaveStdin () {
+ # Generate tempfile
+ my $msgfile = tempfile ();
+
+ # Read STDIN and write it out to the tempfile
+ while (<STDIN>) {
+ print $msgfile $_;
+ } # while
+
+ # Seek to the start of the file (Note if we closed it, it would be deleted)
+ seek $msgfile, 0, 0;
+
+ # Return the filehandle
+ return $msgfile;
+} # SaveStdin
+
+sub save_msg {
+ my ($sender, $sender_long, $reply_to, $subject, $data) = @_;
+
+ open SAVED_MSG, ">>$logpath/$sender"
+ or die "Unable to open $logpath/$sender - $!\n";
+
+ print SAVED_MSG "Sender = $sender\n";
+ print SAVED_MSG "Sender long = $sender\n";
+ print SAVED_MSG "reply_to = $reply_to\n";
+ print SAVED_MSG "subject = $subject\n";
+ print SAVED_MSG "data:\n\n";
+ print SAVED_MSG $data;
+ print SAVED_MSG "*** END OF DATA***\n";
+} # save_msg
+
+sub ValidDomainUser ($) {
+ my ($sender) = @_;
+
+ my ($username, $domainname);
+
+ if ($sender =~ /(.*)\@(.*)/) {
+ $username = $1;
+ $domainname = $2;
+ } else {
+ return 1;
+ } # if
+
+ return 1 if $domainname ne hostdomain;
+
+ # Let BICE email come through
+ return 1 if $username eq "bice";
+
+ my $uid = getpwnam $username;
+
+ return defined $uid ? 1 : 0;
+} # ValidDomainUser
+
+sub ProcessMsgs ($$$) {
+ my ($msgfile, $username, $user_email) = @_;
+
+ return
+ unless $execute;
+
+ while (!eof *$msgfile) {
+ my ($sender, $sender_long, $reply_to, $subject, $data) = ReadMsg (*$msgfile);
+
+ my ($onlist, $rule, $sequence, $hit_count);
+
+ if ($sender eq "" or $sender eq "@" or $sender =~ /.*\@$/) {
+ verbose "Sender not found in message";
+ next;
+ } elsif ($sender eq $user_email and
+ (lc ($sender_long) !~ lc ("\"$username\" <$user_email>") and
+ lc ($sender_long) !~ lc ("$username <$user_email>"))) {
+ verbose "Nulllisting message from sender ($sender_long) pretending to be $user_email";
+ Nulllist $sender;
+ next;
+ } # if
+
+ ($onlist, $rule, $sequence, $hit_count) = OnNulllist $sender;
+
+ if ($onlist) {
+ verbose "Nulllisting $sender";
+ Nulllist $sender, $sequence, $hit_count;
+ next;
+ } # if
+
+ ($onlist, $rule, $sequence, $hit_count) = OnBlacklist $sender;
+
+ if ($onlist) {
+ verbose "Blacklisting $sender";
+ my @msg = split /\n/, $data;
+
+ Blacklist $sender, $sequence, $hit_count, @msg;
+ next;
+ } # if
+
+ ($onlist, $rule, $sequence, $hit_count) = OnWhitelist $sender;
+
+ if ($onlist) {
+ if (ValidDomainUser $sender) {
+ verbose "Whitelisting $sender";
+ Whitelist $sender, $data, $sequence, $hit_count;
+ } else {
+ verbose "Sender from this domain but user not found";
+ Nulllist $sender;
+ } # if
+ } else {
+ if ($sender !~ /\@/) {
+ verbose "Sender ($sender) does not appear to be a valid email address";
+ } else {
+ verbose "Returning message from $sender";
+ ReturnMsg $sender, $reply_to, $subject, $data;
+ } # if
+ } # if
+ } # while
+} # ProcessMsgs
+
+# Main
+GetOptions (
+ 'user=s' => \$userid,
+ 'verbose' => sub { set_verbose },
+ 'debug' => sub { set_debug },
+ 'execute!' => \$execute,
+) || Usage;
+
+my $msgfile;
+
+if ($ARGV[0] and $ARGV[0] ne "") {
+ open $msgfile, $ARGV[0];
+
+ if (!$msgfile) {
+ Error "Unable to open file ($ARGV[0]): $!\n";
+ exit 1;
+ } # if
+} else {
+ $msgfile = SaveStdin;
+} # if
+
+verbose "Starting MAPS....";
+
+my ($username, $user_email) = SetContext $userid
+ or die "$userid is not a registered MAPS user\n";
+
+ProcessMsgs $msgfile, $username, $user_email;
+
+exit 0;
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: $RCSfile: mapsscrub,v $
+# Revision: $Revision: 1.1 $
+# Description: This script scrubs messages from the MAPS database based on the
+# users settings.
+# Author: Andrew@DeFaria.com
+# Created: Fri Nov 29 14:17:21 2002
+# Modified: $Date: 2013/06/12 14:05:47 $
+# Language: perl
+#
+# (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+use strict;
+use warnings;
+
+use FindBin;
+
+use lib $FindBin::Bin;
+
+use MAPS;
+use MAPSUtil;
+
+my $userid;
+my $verbose = defined $ARGV[0] && $ARGV[0] eq "-v" ? 1 : 0;
+my $total_emails = 0;
+my $total_log_entries = 0;
+my $total_list_entries = 0;
+my $total_users_emails = 0;
+
+my ($history, $nbr_emails, $nbr_log_entries, $nbr_list_entries, $users_emails);
+
+format =
+@<<<<<<<<<<<<<<<< @>> @##### @##### @##### @#####
+$userid,$history,$nbr_emails,$nbr_log_entries,$nbr_list_entries,$users_emails
+.
+format STDOUT_TOP =
+@||||||||||||||||||||||||||||||||||||||||||||||||
+"MAPS Scrubber"
+
+User ID Age Email Log List User's Emails
+----------------- --- ------ ------ ------ -------------
+.
+
+sub verbose {
+ my $msg = shift;
+
+ return if $verbose eq 0;
+
+ print "$msg\n";
+} # verbose
+
+sub CleanUp {
+ my $userid = shift;
+
+ my %options = GetUserOptions $userid;
+ $history = $options{"History"};
+ my $timestamp = SubtractDays (Today2SQLDatetime, $history);
+
+ $nbr_emails = CleanEmail $timestamp;
+ $nbr_log_entries = CleanLog $timestamp;
+ $nbr_list_entries = CleanList $timestamp, "null";
+ $users_emails = MAPSDB::count ("email", "userid = \"$userid\"");
+ write () if $verbose;
+
+ return ($nbr_emails, $nbr_log_entries, $nbr_list_entries, $users_emails);
+} # CleanUp
+
+# Main
+my $handle = FindUser;
+
+#$~ = "REPORT" if $verbose;
+
+while (($userid) = GetUser $handle) {
+ last if !defined $userid;
+ SetContext $userid;
+ my ($emails, $log_entries, $list_entries, $users_emails) = CleanUp $userid;
+ $total_emails += $emails;
+ $total_log_entries += $log_entries;
+ $total_list_entries += $list_entries;
+ $total_users_emails += $users_emails;
+} # while
+
+$handle->finish;
+
+if ($verbose) {
+ $userid = "Total:";
+ $history = "n/a";
+ $nbr_emails = $total_emails;
+ $nbr_log_entries = $total_log_entries;
+ $nbr_list_entries = $total_list_entries;
+ $users_emails = $total_users_emails;
+ write ();
+} # if
+
+# Now optimize the database
+OptimizeDB;
+
+exit;
--- /dev/null
+#!/usr/bin/perl
+#################################################################################
+# File: $RCSfile: mapsutil,v $
+# Revision: $Revision: 1.1 $
+# Description: This script implements a small command interpreter to exercise
+# MAPS functions.
+# Author: Andrew@DeFaria.com
+# Created: Fri Nov 29 14:17:21 2002
+# Modified: $Date: 2013/06/12 14:05:47 $
+# Language: perl
+#
+# (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################use strict;
+use warnings;
+
+use FindBin;
+
+use lib $FindBin::Bin;
+
+use MAPS;
+use MAPSLog;
+use Term::ReadLine;
+use Term::ReadLine::Gnu;
+use Term::ReadKey;
+
+sub EncryptPassword {
+ my $password = shift;
+ my $userid = shift;
+
+ my $encrypted_password = Encrypt $password, $userid;
+
+ print "Password: $password = $encrypted_password\n";
+} # EncryptPassword
+
+sub DecryptPassword {
+ my $password = shift;
+ my $userid = shift;
+
+ my $decrypted_password = Decrypt $password, $userid;
+
+ print "Password: $password = $decrypted_password\n";
+} # DecryptPassword
+
+sub Resequence {
+ my $userid = shift;
+ my $type = shift;
+
+ ResequenceList $userid, $type;
+} # Resequence
+
+sub GetPassword {
+ print "Password:";
+ ReadMode "noecho";
+ my $password = ReadLine (0);
+ chomp $password;
+ print "\n";
+ ReadMode "normal";
+
+ return $password
+} # GetPassword
+
+sub Login2MAPS {
+ my $username = shift;
+ my $password = shift;
+
+ if ($username ne "") {
+ $password = GetPassword if !defined $password or $password eq "";
+ } # if
+
+ while (Login ($username, $password) != 0) {
+ print "Login failed!\n";
+ print "Username:";
+ $username = <>;
+ if ($username eq "") {
+ print "Login aborted!\n";
+ return undef;
+ } # if
+ chomp $username;
+ $password = GetPassword;
+ } # if
+
+ return $username;
+} # Login2MAPS
+
+sub LoadListFile {
+ # This function loads a ".list" file. This is to "import" our old ".list"
+ # files. Note it assumes that the ".list" files have specific names.
+ my $listfilename = shift;
+
+ my $listtype;
+
+ if ($listfilename eq "white.list") {
+ $listtype = "white";
+ } elsif ($listfilename eq "black.list") {
+ $listtype = "black";
+ } elsif ($listfilename eq "null.list") {
+ $listtype = "null";
+ } else {
+ print "Unknown list file: $listfilename\n";
+ return;
+ } # if
+
+ if (!open LISTFILE, "<$listfilename") {
+ print "Unable to open $listfilename\n";
+ return;
+ } # if
+
+ my $sequence = 0;
+
+ Info "Adding $listfilename to $listtype list";
+
+ while (<LISTFILE>) {
+ chomp;
+ next if m/^#/ || m/^$/;
+
+ my ($pattern, $comment) = split /\,/;
+
+ AddList $listtype, $pattern, 0, $comment;
+ $sequence++;
+ } # while
+
+ if ($sequence == 0) {
+ print "No messages found to load ";
+ } elsif ($sequence == 1) {
+ print "Loaded 1 message ";
+ } else {
+ print "Loaded $sequence messages ";
+ } # if
+ print "from $listfilename\n";
+
+ close LISTFILE;
+} # LoadListFile
+
+sub LoadEmail {
+ # This function loads an mbox file.
+ my $file = shift;
+
+ if (!open FILE, "<$file") {
+ print "Unable to open \"$file\" - $!\n";
+ return;
+ } # if
+
+ binmode FILE;
+
+ my $nbr_msgs;
+
+ while (! eof FILE) {
+ my ($sender, $reply_to, $subject, $data) = ReadMsg (*FILE);
+
+ $nbr_msgs++;
+
+ AddEmail $sender, $subject, $data;
+
+ Info "Added message from $sender to email";
+ } # while
+
+ if ($nbr_msgs == 0) {
+ print "No messages found to load ";
+ } elsif ($nbr_msgs == 1) {
+ print "Loaded 1 message ";
+ } else {
+ print "Loaded $nbr_msgs messages ";
+ } # if
+ print "from $file\n";
+} # LoadEmail
+
+sub DumpEmail {
+ # This function unloads email to a mbox file.
+ my $file = shift;
+
+ if (!open FILE, ">$file") {
+ print "Unable to open \"$file\" - $!\n";
+ return;
+ } # if
+
+ binmode FILE;
+
+ my $i = 0;
+ my $handle = FindEmail;
+ my ($userid, $sender, $subject, $timestamp, $message);
+
+ while (($userid, $sender, $subject, $timestamp, $message) = GetEmail $handle) {
+ print FILE $message;
+ $i++;
+ } # while
+
+ print "$i messages dumped to $file\n";
+
+ close FILE;
+} # DumpEmail
+
+sub SwitchUser {
+ my $new_user = shift;
+
+ if ($new_user = Login2MAPS $new_user) {
+ print "You are now logged in as $new_user\n";
+ } # if
+} # SwitchContext
+
+sub ShowSpace {
+ my $detail = shift;
+
+ my $userid = GetContext;
+
+ if (defined $detail) {
+ my %msg_space = MAPS::Space $userid;
+
+ foreach (sort (keys (%msg_space))) {
+ my $sender = $_;
+ my $size = $msg_space {$_};
+ format PER_MSG=
+@######### @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+$size,$sender
+.
+$~ = "PER_MSG";
+ write ();
+ } # foreach
+ } else {
+ my $total_space = MAPS::Space $userid;
+ $total_space = $total_space / (1024 * 1024);
+ format TOTALSIZE=
+Total size @###.### Meg
+$total_space
+.
+$~ = "TOTALSIZE";
+ write ();
+ } # if
+} # ShowSpace
+
+sub ShowUser {
+ print "Current userid is " . GetContext () . "\n";
+} # ShowContext
+
+sub ShowUsers {
+ my $handle = FindUser;
+
+ my ($userid, $name, $email);
+
+ format USERLIST =
+User ID: @<<<<<<<<< Name: @<<<<<<<<<<<<<<<<<<< Email: @<<<<<<<<<<<<<<<<<<<<<<<
+$userid,$name,$email
+.
+$~ = "USERLIST";
+ while (($userid, $name, $email) = GetUser $handle) {
+ last if ! defined $userid;
+ write ();
+ } # while
+
+ $handle->finish;
+} # ShowUsers
+
+sub ShowEmail {
+ my $handle = FindEmail;
+
+ my ($userid, $sender, $subject, $timestamp, $message);
+
+format EMAIL =
+@<<<<<<<<<<<<<<<<<<<@<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+$timestamp,$sender,$subject
+.
+$~ = "EMAIL";
+ while (($userid, $sender, $subject, $timestamp, $message) = GetEmail $handle) {
+ last if ! defined $userid;
+ write ();
+ } # while
+
+ $handle->finish;
+} # ShowEmail
+
+sub ShowLog {
+ my $how_many = shift;
+
+ $how_many = defined $how_many ? $how_many : -20;
+
+ my $handle = FindLog $how_many;
+
+ my ($userid, $timestamp, $sender, $type, $message);
+
+format LOG =
+@<<<<<<<<<<<<<<<<<<<@<<<<<<<<< @<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+$timestamp,$type,$sender,$message
+.
+$~ = "LOG";
+ while (($userid, $timestamp, $sender, $type, $message) = GetLog $handle) {
+ last if ! defined $userid;
+ write ();
+ } # while
+
+ $handle->finish;
+} # ShowLog
+
+sub ShowList {
+ my $type = shift;
+
+ my $lines = 10;
+ my $next = 0;
+ my @list;
+ my %record;
+
+format LIST =
+@>> @<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<
+$record{sequence},$record{pattern},$record{domain},$record{comment}
+.
+$~ = "LIST";
+
+ while (@list = ReturnList $type, $next, $lines) {
+ foreach (@list) {
+ %record = %{$_};
+ write ();
+ } # foreach
+ print "Hit any key to continue";
+ ReadLine (0);
+ $next += $lines;
+ } # while
+} # ShowList
+
+sub ShowStats {
+ my $nbr_days = shift;
+
+ $nbr_days = 1 if !defined $nbr_days;
+
+ my %dates = GetStats $nbr_days;
+
+ foreach my $date (keys (%dates)) {
+ foreach (keys (%{$dates{$date}})) {
+ print "$date $_:";
+ print "\t$dates{$date}{$_}\n";
+ } # foreach
+ } # foreach
+} # ShowStats
+
+sub Deliver {
+ my $file = shift;
+
+ if (!open MESSAGE, "<$file") {
+ print "Unable to open message file $file\n";
+ return;
+ } # if
+
+ my $data;
+ while (<MESSAGE>) {
+ $data = $data . $_;
+ } # while
+
+ Whitelist "Andrew\@DeFaria.com", $data;
+} # Deliver
+
+sub ParseCommand {
+ # Crude parser...
+ my $cmd = shift;
+ my $parm1 = shift;
+ my $parm2 = shift;
+ my $parm3 = shift;
+ my $parm4 = shift;
+
+ $_ = $cmd . " ";
+ SWITCH: {
+ /^$/ && do {
+ last SWITCH
+ };
+
+ /^resequence / && do {
+ Resequence GetContext (), $parm1;
+ last SWITCH
+ };
+
+ /^encrypt / && do {
+ EncryptPassword $parm1, $parm2;
+ last SWITCH
+ };
+
+ /^decrypt / && do {
+ my $password = UserExists (GetContext());
+ DecryptPassword $password;
+ last SWITCH
+ };
+
+ /^deliver / && do {
+ Deliver $parm1;
+ last SWITCH
+ };
+
+ /^add2whitelist / && do {
+ Add2Whitelist $parm1, GetContext (), $parm2;
+ last SWITCH
+ };
+
+ /^showusers / && do {
+ ShowUsers;
+ last SWITCH
+ };
+
+ /^adduser / && do {
+ AddUser $parm1, $parm2, $parm3, $parm4;
+ last SWITCH;
+ };
+
+ /^cleanemail / && do {
+ if ($parm1 eq "") {
+ $parm1 = "9999-12-31 23:59:59";
+ } # if
+ my $nbr_entries = CleanEmail $parm1;
+ print "$nbr_entries email entries cleaned\n";
+ last SWITCH;
+ };
+
+ /^deleteemail / && do {
+ my $nbr_entries = DeleteEmail $parm1;
+ print "$nbr_entries email entries deleted\n";
+ last SWITCH;
+ };
+
+ /^cleanlog / && do {
+ if ($parm1 eq "") {
+ $parm1 = "9999-12-31 23:59:59";
+ } # if
+ my $nbr_entries = CleanLog $parm1;
+ print "$nbr_entries log entries cleaned\n";
+ last SWITCH;
+ };
+
+ /^loadlist / && do {
+ LoadListFile $parm1;
+ last SWITCH;
+ };
+
+ /^loademail / && do {
+ LoadEmail $parm1;
+ last SWITCH;
+ };
+
+ /^dumpemail / && do {
+ DumpEmail $parm1;
+ last SWITCH;
+ };
+
+ /^log / && do {
+ Logmsg "info", "$parm1 $parm2", $parm3;
+ last SWITCH;
+ };
+
+ /^switchuser / && do {
+ SwitchUser $parm1;
+ last SWITCH;
+ };
+
+ /^showuser / && do {
+ ShowUser;
+ last SWITCH;
+ };
+
+ /^showemail / && do {
+ ShowEmail;
+ last SWITCH
+ };
+
+ /^showlog / && do {
+ ShowLog $parm1;
+ last SWITCH
+ };
+
+ /^showlist / && do {
+ ShowList $parm1;
+ last SWITCH
+ };
+
+ /^space / && do {
+ ShowSpace $parm1;
+ last SWITCH
+ };
+
+ /^showstats / && do {
+ ShowStats $parm1;
+ last SWITCH
+ };
+
+ /^help / && do {
+ print "Valid commands are:\n\n";
+ print "adduser <userid> <realname> <email> <password>\tAdd user to DB\n";
+ print "add2whitelist <sender> <name>\t\tAdd sender to whitelist\n";
+ print "cleanlog [timestamp]\t\tCleans out old log entries\n";
+ print "log <message>\t\t\tLogs a message\n";
+ print "loadlist <listfile>\t\t\tLoad a list file\n";
+ print "cleanemail [timestamp]\t\tCleans out old email entries\n";
+ print "deliver <message>\t\t\tDelivers a message\n";
+ print "loademail <mbox>\t\t\tLoad an mbox file\n";
+ print "dumpemail <mbox>\t\t\tDump email from DB to an mbox file\n";
+ print "deleteemail <sender>\t\t\tDelete email from sender\n";
+ print "switchuser <userid>\t\t\tSwitch to user\n";
+ print "showuser\t\t\t\tShow current user\n";
+ print "showusers\t\t\t\tShows users in the DB\n";
+ print "showemail\t\t\t\tDisplays email\n";
+ print "showlog <nbr>\t\t\tDisplays <nbr> log entries\n";
+ print "space\t <detail>\t\t\tDisplay space usage\n";
+ print "showlist <type>\t\t\tShow list by type\n";
+ print "showstats <nbr>\t\t\tDisplays <nbr> days of stats\n";
+ print "encrypt <password>\t\t\tEncrypt a password\n";
+ print "resequence <list>\t\t\tResequences a list\n";
+ print "help\t\t\t\t\tThis screen\n";
+ print "exit\t\t\t\t\tExit mapsutil\n";
+ last SWITCH;
+ };
+
+ print "Unknown command: $_";
+
+ print " ($parm1" if defined $parm1;
+ print ", $parm2" if defined $parm2;
+ print ", $parm3" if defined $parm3;
+ print ", $parm4" if defined $parm4;
+
+ if (defined $parm1) {
+ print ")\n";
+ } else {
+ print "\n";
+ } # if
+ } # SWITCH
+} # ParseCommand
+
+sub GetOpts {
+} # GetOpts
+
+my $maps_username = $ENV{MAPS_USERNAME} ? $ENV{MAPS_USERNAME} : $ENV{USER};
+my $username = Login2MAPS $maps_username, $ENV{MAPS_PASSWORD};
+
+if (defined $ARGV [0]) {
+ ParseCommand $ARGV [0], $ARGV [1], $ARGV [2], $ARGV [3];
+ exit;
+} # if
+
+# Use ReadLine
+my $term = new Term::ReadLine 'mapsutil';
+
+while (1) {
+ $_ = $term->readline ("MAPSUtil:");
+
+ last if !defined $_;
+
+ my ($cmd, $parm1, $parm2, $parm3, $parm4) = split;
+
+ last if ($cmd =~ /exit/i || $cmd =~ /quit/i);
+
+ ParseCommand $cmd, $parm1, $parm2, $parm3, $parm4 if defined $cmd;
+} # while
+
+print "\n" if !defined $_;
+
+exit;
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: $RCSfile: modifyentries.cgi,v $
+# Revision: $Revision: 1.1 $
+# Description: Modify list entries
+# Author: Andrew@DeFaria.com
+# Created: Mon Jan 16 20:25:32 PST 2006
+# Modified: $Date: 2013/06/12 14:05:47 $
+# Language: perl
+#
+# (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+use strict;
+use warnings;
+
+use FindBin;
+$0 = $FindBin::Script;
+
+use lib $FindBin::Bin;
+
+use MAPS;
+use MAPSLog;
+use MAPSWeb;
+
+use CGI qw/:standard/;
+use CGI::Carp 'fatalsToBrowser';
+
+my $userid = cookie ('MAPSUser');
+my $type = param ('type');
+my $next = param ('next');
+
+$userid ||= $ENV{USER};
+
+sub ReturnSequenceNbrs {
+ my @names = param;
+ my @sequence_nbrs;
+
+ foreach (@names) {
+ if (/pattern(\d+)/) {
+ push @sequence_nbrs, $1;
+ } # if
+ } # foreach
+
+ return @sequence_nbrs;
+} # ReturnSequenceNbrs
+
+# Main
+my $i = 0;
+
+
+foreach (ReturnSequenceNbrs) {
+ UpdateList
+ $userid,
+ $type,
+ param ("pattern$_"),
+ param ("domain$_"),
+ param ("comment$_"),
+ $_;
+ $i++;
+} # foreach
+
+if ($i eq 0) {
+ print redirect ("/maps/php/list.php?type=$type&next=$next&message=Unable to update entries");
+} elsif ($i eq 1) {
+ print redirect ("/maps/php/list.php?type=$type&next=$next&message=Modified entry");
+} else {
+ print redirect ("/maps/php/list.php?type=$type&next=$next&message=Modified entries");
+} # if
+
+exit;
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: $RCSfile: nuke,v $
+# Revision: $Revision: 1.1 $
+# Description: Displays list of email addresses based on report type.
+# Author: Andrew@DeFaria.com
+# Created: Fri Nov 29 14:17:21 2002
+# Modified: $Date: 2013/06/12 14:05:47 $
+# Language: perl
+#
+# (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+use strict;
+use warnings;
+
+use FindBin;
+
+use lib $FinBin::Bin, '/opt/clearscm/lib';
+
+use MAPS;
+
+use Display;
+
+# Just me
+my $userid = "andrew";
+
+sub GetMailLoops {
+ my $type = "mailloop";
+
+ my @emails;
+
+ # Hack: ReturnEmails normally wants a start and end range of what
+ # emails to get. We really want all of them so let's just use 10000.
+ @emails = ReturnEmails $userid, $type, 0, 10000;
+
+ my %senders;
+
+ foreach (@emails) {
+ my $sender = shift @{$_};
+ my @msgs = @{$_};
+ my ($pattern, $domain) = split (/@/, $sender);
+
+ if (scalar @msgs > 0) {
+ $senders{$domain} = scalar @msgs;
+ } # if
+ } # foreach
+
+ return %senders;
+} # GetMailLoops
+
+sub Add2List {
+ my $type = shift;
+ my @items = @_;
+
+ my $sender = "";
+ my $nextseq = MAPSDB::GetNextSequenceNo $userid, $type;
+
+ foreach (@items) {
+ my $domain = "\@$_";
+
+ display_nolf "Adding $domain to null list ($nextseq)...";
+
+ if (OnNulllist $domain) {
+ display_nolf " Already on list";
+ DeleteLog $domain;
+ display " - cleaned";
+ } else {
+ Add2Nulllist $domain, $userid, "";
+ display " done";
+
+ # Now remove this entry from the other lists (if present)
+ foreach my $otherlist ("white", "black") {
+ my $sth = FindList $otherlist, $domain;
+ my ($sequence, $count);
+ ($_, $_, $_, $_, $_, $sequence) = GetList $sth;
+ if (defined $sequence) {
+ $count = DeleteList $otherlist, $sequence;
+ } # if
+ } # foreach
+ } # if
+ $nextseq++;
+ } # while
+} # Add2List
+
+# Main
+
+# Set no output buffering
+$| = 1;
+
+# Let's be nice
+setpriority 0, 0, 10;
+
+SetContext $userid;
+
+my %senders = GetMailLoops;
+
+foreach (sort (keys (%senders))) {
+ print "\@$_\n";
+} # foreach
+
+if (scalar keys (%senders) eq 0) {
+ display "No mailloops detected";
+ exit 0;
+} # if
+
+print "Nuke these domains? ";
+$_ = <STDIN>;
+
+if (/y/i) {
+ Add2List "null", (sort (keys (%senders)));
+} # if
+
+exit;
--- /dev/null
+#!/usr/bin/perl
+#################################################################################
+#
+# File: $RCSfile: processaction.cgi,v $
+# Revision: $Revision: 1.1 $
+# Description: Process the action
+# Author: Andrew@DeFaria.com
+# Created: Mon Jan 16 20:25:32 PST 2006
+# Modified: $Date: 2013/06/12 14:05:47 $
+# Language: Perl
+#
+# (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+use strict;
+use warnings;
+
+use FindBin;
+$0 = $FindBin::Script;
+
+use lib $FindBin::Bin;
+
+use MAPS;
+use MAPSWeb;
+
+use CGI qw (:standard *table start_Tr end_Tr);
+use CGI::Carp 'fatalsToBrowser';
+
+my $type = param 'type';
+my $action = param 'action';
+my $next = param 'next';
+my $userid = cookie 'MAPSUser';
+my $lines;
+my $total;
+my $table_name = 'list';
+
+my @scripts = ('ListActions.js');
+
+sub ReturnSequenceNbrs {
+ my @names = param;
+ my @sequence_nbrs;
+
+ Debug "Entered ReturnSequenceNbrs";
+
+ foreach (@names) {
+ if (/action(\d+)/) {
+ push @sequence_nbrs, $1;
+ } # if
+ } # foreach
+
+ Debug "Returning sequence nbrs " . join ' ', @sequence_nbrs;
+
+ return @sequence_nbrs;
+} # ReturnSequenceNbrs
+
+sub DeleteEntries {
+ my ($type) = @_;
+
+ my @sequence_nbrs = ReturnSequenceNbrs;
+
+ my $count;
+
+ foreach (@sequence_nbrs) {
+ $count += DeleteList $type, $_;
+ } # foreach
+
+ if ($count eq 0) {
+ DisplayError 'Nothing to delete!';
+ } else {
+ ResequenceList $userid, $type;
+
+ if ($count eq 1) {
+ print redirect ("/maps/php/list.php?type=$type&next=$next&message=Deleted entry");
+ } else {
+ print redirect ("/maps/php/list.php?type=$type&next=$next&message=Deleted $count entries");
+ } # if
+ } # if
+
+ return $count;
+} # DeleteEntries
+
+sub PrintInputLine ($$$$$) {
+ my ($nextseq, $email_nbr, $leftclass, $dataclass, $rightclass) = @_;
+
+ my $email = '';
+ my $pattern = '';
+ my $domain = '';
+
+ if (defined $email_nbr && $email_nbr ne '') {
+ $email = param "email$email_nbr";
+ if ($email && $email ne '') {
+ ($pattern, $domain) = split /\@/, $email;
+ } # if
+ } # if
+
+ print Tr [
+ td {-class => $leftclass,
+ -align => 'center'}, "$nextseq",
+ td {-class => $dataclass,
+ -align => 'right'},
+ (textfield {-class => 'inputfield',
+ -style => 'width:100%',
+ -align => 'right',
+ -size => 25,
+ -maxlength => '255',
+ -name => "pattern$nextseq",
+ -value => $pattern}),
+ td {-class => $dataclass,
+ -align => 'center'}, '@',
+ td {-class => $dataclass},
+ (textfield {-class => 'inputfield',
+ -style => 'width:100%',
+ -align => 'left',
+ -size => 25,
+ -maxlength => '255',
+ -name => "domain$nextseq",
+ -value => $domain}),
+ td {-class => $rightclass},
+ (textfield {-class => 'inputfield',
+ -style => 'width:100%',
+ -align => 'left',
+ -size => 25,
+ -maxlength => '255',
+ -name => "comment$nextseq",
+ -value => ''}),
+ ];
+} # PrintInputLine
+
+sub AddNewEntry {
+ my ($type, @selected) = @_;
+
+ # First display the last page and add the appropriate number of
+ # empty, editable entries (possibly filled in) for the user to add
+ # the new entry
+ my $selected = @selected;
+ my $nextseq = MAPSDB::GetNextSequenceNo $userid, $type;
+ my $next = ($nextseq - $lines) + $selected - 1;
+
+ $next = 0
+ if $next < 0;
+
+ my $Type = ucfirst $type;
+
+ Heading (
+ 'getcookie',
+ '',
+ "Add to $Type List",
+ "Add to $Type List",
+ '',
+ $table_name,
+ @scripts
+ );
+
+ NavigationBar $userid;
+
+ # Now display table and new entry
+ print start_form {
+ -method => 'post',
+ -action => 'add2' . $type . 'list.cgi',
+ -name => 'list'
+ };
+
+ print start_table {-align => 'center',
+ -id => $table_name,
+ -border => 0,
+ -cellspacing => 0,
+ -cellpadding => 4,
+ -width => '100%'};
+ print Tr [
+ th {-class => 'tableleftend'}, 'Seq',
+ th {-class => 'tableheader'}, 'Username',
+ th {-class => 'tableheader'}, '@',
+ th {-class => 'tableheader'}, 'Domain',
+ th {-class => 'tablerightend'}, 'Comments'
+ ];
+
+ my @list = ReturnList $type, $next, $lines;
+ my %record;
+ my $i = 1;
+
+ foreach (@list) {
+ $i++;
+
+ %record = %{$_};
+
+ # Normalize fields
+ my $sequence = $record{sequence};
+ my $pattern = $record{pattern} ? $record{pattern} : ' ';
+ my $domain = $record{domain} ? $record{domain} : ' ';
+ my $comment = $record{comment} ? $record{comment} : ' ';
+
+ print Tr [
+ td {-class => 'tableleftdata',
+ -align => 'center'}, $sequence,
+ td {-class => 'tabledata',
+ -align => 'right'}, $pattern,
+ td {-class => 'tabledata',
+ -align => 'center'}, '@',
+ td {-class => 'tabledata',
+ -align => 'left'}, $domain,
+ td {-class => 'tablerightdata',
+ -align => 'left'}, $comment
+ ];
+ } # foreach
+
+ # Now the input line(s)
+ if (@selected eq 0) {
+ PrintInputLine $nextseq, undef, 'tablebottomleft', 'tablebottomdata',
+ 'tablebottomright';
+ } else {
+ foreach (@selected) {
+ my $leftclass = $i == $lines ? 'tablebottomleft' : 'tableleftdata';
+ my $dataclass = $i == $lines ? 'tablebottomdata' : 'tabledata';
+ my $rightclass = $i == $lines ? 'tablebottomright' : 'tablerightdata';
+ $i++;
+ PrintInputLine $nextseq++, $_, $leftclass, $dataclass, $rightclass;
+ } # foreach
+ } # for
+
+ print end_table;
+ print br,
+ '<center>',
+ submit ({-name => 'update',
+ -value => 'Update',
+ -onClick => 'return CheckEntry (document.list);'}),
+ submit ({-name => 'Reset',
+ -value => 'Reset',
+ -onClick => 'history.back(); return false'}),
+ '</center>';
+ print end_form;
+} # AddNewEntry
+
+sub ModifyEntries {
+ my ($type) = @_;
+
+ my @selected = ReturnSequenceNbrs;
+
+ my $Type = ucfirst $type;
+
+ Heading (
+ 'getcookie',
+ '',
+ "Modify $Type List",
+ "Modify $Type List",
+ '',
+ $table_name,
+ @scripts
+ );
+
+ NavigationBar $userid;
+
+ # Redisplay the page but open up the lines that are getting modified
+ print start_form {
+ -method => 'post',
+ -action => 'modifyentries.cgi',
+ -name => 'list'
+ };
+
+ # Print some hidden fields to pass along
+ print
+ hidden ({-name => 'type',
+ -default => $type}),
+ hidden ({-name => 'next',
+ -default => $next});
+
+ print start_table {-align => 'center',
+ -id => $table_name,
+ -border => 0,
+ -cellspacing => 0,
+ -cellpadding => 4,
+ -width => '100%'};
+ print Tr [
+ th {-class => 'tableleftend'}, 'Seq',
+ th {-class => 'tableheader'}, 'Username',
+ th {-class => 'tableheader'}, '@',
+ th {-class => 'tableheader'}, 'Domain',
+ th {-class => 'tablerightend'}, 'Comments'
+ ];
+
+ my @list = ReturnList $type, $next, $lines;
+ my %record;
+ my $s = 0;
+ my $i = 1;
+
+ foreach (@list) {
+ %record = %{$_};
+
+ my $sequence = $record{sequence};
+ my $leftclass = ($i eq $lines || $sequence eq $total) ?
+ 'tablebottomleft' : 'tableleftdata';
+ my $dataclass = ($i eq $lines || $sequence eq $total) ?
+ 'tablebottomdata' : 'tabledata';
+ my $rightclass = ($i eq $lines || $sequence eq $total) ?
+ 'tablebottomright' : 'tablerightdata';
+
+ $i++;
+
+ print start_Tr,
+ td {-class => $leftclass,
+ -align => 'center'}, $record{sequence};
+
+ if ($record{sequence} eq $selected[$s]) {
+ $s++;
+ # Normalize fields
+ my $pattern = $record{pattern} ? $record{pattern} : '';
+ my $domain = $record{domain} ? $record{domain} : '';
+ my $comment = $record{comment} ? $record{comment} : '';
+
+ print
+ td {-class => $dataclass,
+ -align => 'right'},
+ (textfield {-class => 'inputfield',
+ -style => 'width:100%',
+ -align => 'right',
+ -size => 25,
+ -maxlength => '255',
+ -name => "pattern$sequence",
+ -value => $pattern}),
+ td {-class => $dataclass,
+ -align => 'center'}, '@',
+ td {-class => $dataclass},
+ (textfield {-class => 'inputfield',
+ -style => 'width:100%',
+ -align => 'left',
+ -size => 25,
+ -maxlength => '255',
+ -name => "domain$sequence",
+ -value => $domain}),
+ td {-class => $rightclass},
+ (textfield {-class => 'inputfield',
+ -style => 'width:100%',
+ -align => 'left',
+ -size => 25,
+ -maxlength => '255',
+ -name => "comment$sequence",
+ -value => $comment});
+ } else {
+ # Put in ' ' for undefined fields
+ my $pattern = $record{pattern} ? $record{pattern} : ' ';
+ my $domain = $record{domain} ? $record{domain} : ' ';
+ my $comment = $record{comment} ? $record{comment} : ' ';
+
+ print
+ td {-class => $dataclass,
+ -align => 'right'}, $pattern,
+ td {-class => $dataclass,
+ -align => 'center'}, '@',
+ td {-class => $dataclass,
+ -align => 'left'}, $domain,
+ td {-class => $rightclass,
+ -align => 'left'}, $comment;
+ } # if
+
+ print end_Tr;
+ } # foreach
+
+ print end_table;
+ print br,
+ '<center>',
+ submit ({-name => 'update',
+ -value => 'Update',
+ -onClick => 'return CheckEntry (document.list);'}),
+ submit ({-name => 'Reset',
+ -value => 'Reset',
+ -onClick => 'history.back(); return false'}),
+ '</center>';
+ print end_form;
+} # ModifyEntries
+
+sub WhitelistMarked {
+ AddNewEntry 'white', ReturnSequenceNbrs;
+} # WhitelistMarked
+
+sub BlacklistMarked {
+ AddNewEntry 'black', ReturnSequenceNbrs;
+} # BlacklistMarked
+
+sub NulllistMarked {
+ AddNewEntry 'null', ReturnSequenceNbrs;
+} # NulllistMarked
+
+# Main
+$userid ||= $ENV{USER};
+
+SetContext $userid;
+
+my %options = GetUserOptions $userid;
+
+$lines = $options{'Page'};
+
+$total = MAPSDB::count 'list', "userid = \"$userid\" and type = \"$type\""
+ if $type;
+
+if ($action eq 'Add New Entry') {
+ AddNewEntry $type;
+} elsif ($action eq 'Delete Marked') {
+ DeleteEntries $type;
+} elsif ($action eq 'Modify Marked') {
+ ModifyEntries $type;
+} elsif ($action eq 'Whitelist Marked') {
+ WhitelistMarked;
+} elsif ($action eq 'Blacklist Marked') {
+ BlacklistMarked;
+} elsif ($action eq 'Nulllist Marked') {
+ NulllistMarked;
+} else {
+ Heading (
+ 'getcookie',
+ '',
+ "Unknown action ($action)",
+ "Unknown action ($action)"
+ );
+
+ NavigationBar $userid;
+ DisplayError "Unknown action encountered ($action)";
+} # if
+
+Footing $table_name;
+
+exit;
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: $RCSfile: register.cgi,v $
+# Revision: $Revision: 1.1 $
+# Description: Register a MAPS user
+# Author: Andrew@DeFaria.com
+# Created: Mon Jan 16 20:25:32 PST 2006
+# Modified: $Date: 2013/06/12 14:05:47 $
+# Language: perl
+#
+# (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+use strict;
+use warnings;
+
+use FindBin;
+$0 = $FindBin::Script;
+
+use lib $FindBin::Bin;
+
+use MAPS;
+use MAPSLog;
+use MAPSWeb;
+
+use CGI qw/:standard/;
+
+my $fullname = param ("fullname");
+my $sender = lc (param ("sender"));
+my $userid = param ("userid");
+
+sub MyFooting {
+ print div ({-align => "center"},
+ button (-name => "close",
+ -value => "Close Window",
+ -onClick => "window.close ()"));
+ print end_html;
+} # MyFooting
+
+sub MyError {
+ my $errmsg = shift;
+
+ print h3 ({-class => "error",
+ -align => "center"}, "ERROR: " . $errmsg);
+
+ MyFooting;
+
+ exit 1;
+} # MyError
+
+sub MyHeading {
+ print
+ header (-title => "MAPS Registration"),
+ start_html (-title => "MAPS Registration",
+ -author => "Andrew\@DeFaria.com",
+ -style => {-src => "/maps/css/MAPSPlain.css"});
+ print
+ h2 ({-class => "header",
+ -align => "center"},
+ font ({-class => "standout"},
+ "MAPS"), "Registration Results");
+} # MyHeading
+
+# Main
+MyHeading;
+
+if ($sender eq "") {
+ MyError "Sender not specified!";
+}
+
+my $rule;
+
+if (OnWhitelist $sender, $userid) {
+ MyError "The email address $sender is already on ${userid}'s list"
+} # if
+
+my $messages = Add2Whitelist $sender, $userid, $fullname;
+
+print p "$fullname, your email address, $sender, has been added to ${userid}'s white list.";
+
+if ($messages > 0) {
+ if ($messages == 1) {
+ print p "Your previous message has been delivered\n";
+ } else {
+ print p "Your previous $messages messages have been delivered\n";
+ } # if
+} elsif ($messages == -1) {
+ MyError "Unable to deliver message";
+} else {
+ print p "Unable to find any old messages but future messages will now be delivered.";
+} # if
+
+MyFooting;
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: $RCSfile: registerform.cgi,v $
+# Revision: $Revision: 1.1 $
+# Description: Register a MAPS user
+# Author: Andrew@DeFaria.com
+# Created: Mon Jan 16 20:25:32 PST 2006
+# Modified: $Date: 2013/06/12 14:05:47 $
+# Language: perl
+#
+# (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+use strict;
+use warnings;
+
+use FindBin;
+$0 = $FindBin::Script;
+
+use CGI qw/:standard *table start_div end_div/;
+
+use MAPS;
+use MAPSWeb;
+
+my $userid = param ("userid");
+my $Userid = ucfirst $userid;
+my $sender = param ("sender");
+my $errormsg = param ("errormsg");
+
+sub Heading {
+ print
+ header (-title => "MAPS Registration"),
+ start_html (-title => "MAPS Registration",
+ -author => "Andrew\@DeFaria.com",
+ -style => {-src => "/maps/css/MAPSPlain.css"},
+ -script => [{ -language => "JavaScript1.2",
+ -src => "/maps/JavaScript/MAPSUtils.js"},
+ { -language => "JavaScript1.2",
+ -src => "/maps/JavaScript/CheckRegistration.js"}
+ ]);
+ print
+ h2 ({-class => "header", -align => "center"},
+ font ({-class => "standout"}, "MAPS"),
+ "Mail Authorization and Permission System");
+
+ if (defined $errormsg) {
+ DisplayError $errormsg;
+ exit;
+ } # if
+} # Heading
+
+sub Body {
+ print start_div {-class => "content"};
+ print p ("${Userid}'s email is protected by MAPS, a spam elimination
+ system. In order to email $Userid you must register. You need
+ only register once to be added to ${Userid}'s <i>white list</i>,
+ thereafter you should have no problems emailing them. This is not
+ unlike the acceptance procedure for many instant messaging clients.");
+ print p ("Please enter your full name and click on Register to complete the
+ registration.");
+ print start_form {
+ -method => "post",
+ -action => "register.cgi",
+ -onSubmit => "return validate (this);"
+ };
+ print start_table {
+ -cellpadding => 2,
+ -cellspacing => 0,
+ -border => 0,
+ -align => "center",
+ -width => "360"
+ };
+ print hidden (-name => "userid",
+ -value => "$userid");
+ print Tr [
+ td ({-class => "header"}, "Full name:") .
+ td (textfield {-class => "inputfield",
+ -size => 50,
+ -name => "fullname"})
+ ];
+ print hidden (-name => "sender",
+ -value => "$userid");
+ print end_table;
+ print p {-align => "center"},
+ submit (-name => "submit",
+ -value => "Register");
+ print end_form;
+ print p ("Tired of dealing with unsolicited email (AKA SPAM)? Want to know
+ more about MAPS, the Mail Authorization and Permission System for
+ eliminating SPAM? Click",
+ a ({-href => "/maps/",
+ -target => "_blank"},
+ "here"),
+ "to find out more.");
+ print start_table {
+ -cellpadding => 2,
+ -cellspacing => 0,
+ -border => 1,
+ -align => "center",
+ -width => "50%"
+ };
+ print Tr [
+ td ({-class => "note",
+ -align => "center"}, "Note")
+ ];
+ print Tr [
+ td ({-class => "notetext"},
+ "This registration process is instantaneous however we reserve the
+ right to remove you from the ${Userid}'s white list should you abuse
+ this privilege.")
+ ];
+ print end_table;
+ print end_div;
+} # Body
+
+if (!defined $userid) {
+ $errormsg = "Internal error: Userid not specified";
+} else {
+ if (!UserExists ($userid)) {
+ $errormsg = "Sorry but $userid is no longer a MAPS user";
+ } # if
+}
+
+Heading;
+Body;
+Footing;
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: $RCSfile: search.cgi,v $
+# Revision: $Revision: 1.1 $
+# Description: Search by sender and subject
+# Author: Andrew@DeFaria.com
+# Created: Mon Jan 16 20:25:32 PST 2006
+# Modified: $Date: 2013/06/12 14:05:47 $
+# Language: perl
+#
+# (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+use strict;
+use warnings;
+
+use FindBin;
+$0 = $FindBin::Script;
+
+use lib $FindBin::Bin;
+
+use MAPS;
+use MAPSWeb;
+use MAPSUtil;
+use CGI qw (:standard *table start_Tr start_td start_div end_Tr end_td end_div);
+use CGI::Carp "fatalsToBrowser";
+
+my $str = param ("str");
+my $next = param ("next");
+my $lines = param ("lines");
+my $userid;
+my $prev;
+my $total;
+my $last;
+my $table_name = "searchresults";
+
+sub MakeButtons {
+ my $prev_button = $prev >= 0 ?
+ a ({-href => "search.cgi?str=$str;next=$prev"},
+ "<img src=/maps/images/previous.gif border=0 alt=Previous align=middle>") : "";
+ my $next_button = ($next + $lines) < $total ?
+ a {-href => "search.cgi?str=$str;next=" . ($next + $lines)},
+ "<img src=/maps/images/next.gif border=0 alt=Next align=middle>" : "";
+
+ my $buttons = $prev_button;
+
+ $buttons = $buttons .
+ submit ({-name => "action",
+ -value => "Whitelist Marked",
+ -onClick => "return CheckAtLeast1Checked (document.detail);"}) .
+ submit ({-name => "action",
+ -value => "Blacklist Marked",
+ -onClick => "return CheckAtLeast1Checked (document.detail);"}) .
+ submit ({-name => "action",
+ -value => "Nulllist Marked",
+ -onClick => "return CheckAtLeast1Checked (document.detail);"}) .
+ submit ({-name => "action",
+ -value => "Reset Marks",
+ -onClick => "return ClearAll (document.detail);"});
+
+ return $buttons . $next_button;
+} # MakeButtons
+
+sub HighlightSearchStr {
+ $_ = shift;
+
+ my $highlighted_str = font {-class => "found"}, $str;
+
+ s/$str/<font class=\"found\">$&<\/font>/gi;
+
+ return $_;
+} # HighlightSearchStr
+
+sub Body {
+ my @emails;
+
+ @emails = SearchEmails $userid, $str;
+
+ my $current = $next + 1;
+
+ print div {-align => "center"}, b (
+ "(" . $current . "-" . $last . " of " . $total . ")");
+ print start_form {
+ -method => "post",
+ -action => "processaction.cgi",
+ -name => "detail"
+ };
+ my $buttons = MakeButtons;
+ print div {-align => "center",
+ -class => "toolbar"}, $buttons;
+ print start_table ({-align => "center",
+ -id => $table_name,
+ -border => 0,
+ -cellspacing => 0,
+ -cellpadding => 0,
+ -width => "100%"}) . "\n";
+ print
+ Tr [
+ th {-class => "tableleftend"},
+ th {-class => "tableheader"}, "Sender",
+ th {-class => "tableheader"}, "Subject",
+ th {-class => "tablerightend"}, "Date"
+ ];
+
+ foreach (@emails) {
+ my $sender = shift @{$_};
+ my $subject = shift @{$_};
+ my $date = shift @{$_};
+
+ my $display_sender = HighlightSearchStr $sender;
+ $subject = HighlightSearchStr $subject;
+ $subject = $subject eq "" ? "<Unspecified>" : $subject;
+
+ $next++;
+
+ print Tr [
+ td {-class => "tableleftdata",
+ -align => "center"},
+ (checkbox {-name => "action$next",
+ -label => ""}),
+ hidden ({-name => "email$next",
+ -default => $sender}),
+ td {-class => "sender"},
+ a {-href => "mailto:$sender"}, $display_sender,
+ td {-class => "subject"},
+ a {-href => "display.cgi?sender=$sender"}, $subject,
+ td {-class => "dateright",
+ -width => "115"}, SQLDatetime2UnixDatetime $date
+ ];
+ } # foreach
+ print end_table;
+} # Body
+
+# Main
+my @scripts = ("ListActions.js");
+
+$userid = Heading (
+ "getcookie",
+ "",
+ "Search Results",
+ "Search Results for \"$str\"",
+ "",
+ $table_name,
+ @scripts
+);
+
+SetContext $userid;
+NavigationBar $userid;
+
+DisplayError "No search string specified" if !defined $str;
+
+if (!defined $lines) {
+ my %options = GetUserOptions $userid;
+ $lines = $options{"Page"};
+} # if
+
+$total = MAPSDB::count "email",
+ "userid = \"$userid\" and (subject like \"%$str%\" or sender like \"%$str%\")";
+
+DisplayError "Nothing matching!" if $total eq 0;
+
+$next = !defined $next ? 0 : $next;
+$last = $next + $lines < $total ? $next + $lines : $total;
+
+if (($next - $lines) > 0) {
+ $prev = $next - $lines;
+} else {
+ $prev = $next eq 0 ? -1 : 0;
+} # if
+
+Body;
+
+Footing $table_name;
+
+exit;
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: $RCSfile: signup.cgi,v $
+# Revision: $Revision: 1.1 $
+# Description: Sign up a MAPS user
+# Author: Andrew@DeFaria.com
+# Created: Mon Jan 16 20:25:32 PST 2006
+# Modified: $Date: 2013/06/12 14:05:47 $
+# Language: perl
+#
+# (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+use strict;
+use warnings;
+
+use FindBin;
+$0 = $FindBin::Script;
+
+use lib $FindBin::New;
+
+use MAPS;
+use MAPSWeb;
+
+use CGI qw (:standard);
+
+my $userid = param ("userid");
+my $fullname = param ("fullname");
+my $email = param ("email");
+my $password = param ("password");
+my $repeated_password = param ("repeated_password");
+my $mapspop = param ("MAPSPOP");
+my $history = param ("history");
+my $days = param ("days");
+my $dates = param ("dates");
+my $tag_and_forward = param ("tag_and_forward");
+my $message;
+
+sub MyError {
+ my $errmsg = shift;
+
+ $userid = Heading (
+ "getcookie",
+ "",
+ "Signup",
+ "Signup"
+ );
+
+ NavigationBar $userid;
+
+ print h2 {-align => "center",
+ -class => "error"}, "Error: " . $errmsg;
+
+ Footing;
+
+ exit 1;
+} # MyError
+
+sub Body {
+ # Check required fields
+ if ($userid eq "" ) {
+ MyError "You must specify a userid!";
+ } # if
+ if ($email eq "" ) {
+ MyError "You must specify an email address!";
+ } # if
+ if ($password eq "") {
+ MyError "You must specify a password!";
+ } # if
+ if ($fullname eq "") {
+ MyError "You must specify your full name!";
+ } # if
+
+ # Password field checks
+ if (length $password < 6) {
+ MyError "Password must be longer than 6 characters!";
+ } # if
+ if ($password ne $repeated_password) {
+ MyError "Passwords do not match";
+ } # if
+
+ my $status = AddUser $userid, $fullname, $email, $password;
+
+ if ($status ne 0) {
+ MyError "Username already exists";
+ } # if
+
+ my %options = (
+ "MAPSPOP" => $mapspop,
+ "History" => $history,
+ "Page" => $days,
+ "Dates" => $dates,
+ "Tag&Forward" => $tag_and_forward
+ );
+
+ my $status = AddUserOptions $userid, %options;
+
+ if ($status == 0) {
+ print redirect ("/maps/?errormsg=User account \"$userid\" created.<br>You may now login");
+ } elsif ($status == 1) {
+ MyError "Username \"$userid\" already exists";
+ } else {
+ MyError "Unable to add useropts for \"$userid\"";
+ } # if
+} # Body
+
+Body;
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: $RCSfile: stats.cgi,v $
+# Revision: $Revision: 1.1 $
+# Description: This script produces a table of statistics of mail processed for
+# the user.
+# Author: Andrew@DeFaria.com
+# Created: Fri Nov 29 14:17:21 2002
+# Modified: $Date: 2013/06/12 14:05:47 $
+# Language: perl
+#
+# (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+use strict;
+use warnings;
+
+use FindBin;
+$0 = $FindBin::Script;
+
+use lib $FindBin::Bin;
+
+use MAPS;
+use MAPSLog;
+use MAPSUtil;
+use MAPSWeb;
+
+use CGI qw (:standard *table start_Tr end_Tr);
+use CGI::Carp "fatalsToBrowser";
+
+my $nbr_days = param ("nbr_days");
+my $date = param ("date");
+
+my $table_name = "stats";
+
+$date = defined $date ? $date : Today2SQLDatetime;
+
+sub Body {
+ print start_table ({-align => "center",
+ -id => $table_name,
+ -border => 0,
+ -cellspacing => 0,
+ -cellpadding => 2,
+ -cols => 9,
+ -width => "100%"});
+ print start_Tr {-valign => "bottom"};
+ print th {-class => "tableleftend"}, "Date";
+
+ foreach (@Types) {
+ print th {-class => "tableheader"}, ucfirst;
+ } # foreach
+
+ print th {-class => "tablerightend"}, "Total";
+
+ my %dates = GetStats $nbr_days, $date;
+ my %totals;
+
+ foreach my $date (sort {$b cmp $a} (keys (%dates))) {
+ print start_Tr;
+ print td {-class => "tablerightleftdata",
+ -align => "center"}, FormatDate $date;
+
+ my $day_total = 0;
+
+ foreach (@Types) {
+ my $value = $dates{$date}{$_};
+ if ($value eq 0) {
+ print td {-class => "tabledata"}, " ";
+ } else {
+ print td {-class => "tabledata",
+ -align => "center"},
+ a {-href => "detail.cgi?type=$_;date=$date"},
+ $value;
+ } # if
+ $totals{$_} += $value;
+ $day_total += $value;
+ } # foreach
+
+ if ($day_total eq 0) {
+ print td {-class => "tableleftrightdata"}, " ";
+ } else {
+ print td {-class => "tableleftrightdata",
+ -align => "center"}, $day_total;
+ } # if
+
+ print end_Tr;
+ } # foreach
+
+ my $grand_total = 0;
+
+ print start_Tr;
+ print th {-class => "tablebottomlefttotal"}, "Totals";
+
+ foreach (@Types) {
+ if ($totals{$_} eq 0) {
+ print td {-class => "tablebottomtotal"}, " ";
+ } else {
+ print td {-class => "tablebottomtotal",
+ -align => "center"},
+ a {-href => "detail.cgi?type=$_"}, $totals{$_};
+ } # if
+
+ $grand_total += $totals{$_};
+ } # foreach
+
+ print td {-class => "tablebottomrighttotal",
+ -align => "center"}, $grand_total;
+
+ print end_Tr;
+ print end_table;
+} # Body
+
+# Main
+my $userid = Heading (
+ "getcookie",
+ "",
+ "Statistics",
+ "Statistics",
+ "",
+ $table_name
+);
+
+SetContext $userid;
+
+if (!defined $nbr_days) {
+ my %options = GetUserOptions $userid;
+ $nbr_days = $options{"Dates"};
+} # if
+
+NavigationBar $userid;
+
+Body;
+
+Footing $table_name;
+
+exit;
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: $RCSfile: updateprofile.cgi,v $
+# Revision: $Revision: 1.1 $
+# Description: Update the users profile
+# Author: Andrew@DeFaria.com
+# Created: Mon Jan 16 20:25:32 PST 2006
+# Modified: $Date: 2013/06/12 14:05:47 $
+# Language: perl
+#
+# (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+use strict;
+use warnings;
+
+use FindBin;
+$0 = $FindBin::Script;
+
+use lib $FindBin::Bin;
+
+use MAPS;
+use MAPSWeb;
+
+use CGI qw (:standard);
+
+my $userid;
+my $Userid;
+my $fullname = param ("fullname");
+my $email = param ("email");
+my $old_password = param ("old_password");
+my $new_password = param ("new_password");
+my $repeated_password = param ("repeated_password");
+my $mapspop = param ("MAPSPOP");
+my $history = param ("history");
+my $days = param ("days");
+my $dates = param ("dates");
+my $tag_and_forward = param ("tag_and_forward");
+
+sub Body {
+ my %options = (
+ "MAPSPOP" => $mapspop,
+ "History" => $history,
+ "Page" => $days,
+ "Dates" => $dates,
+ "Tag&Forward" => $tag_and_forward
+ );
+
+ if (defined $old_password && $old_password ne "") {
+ my $dbpassword = UserExists $userid;
+ my $encrypted_old_password = Encrypt $old_password, $userid;
+
+ if ($dbpassword ne $encrypted_old_password) {
+ DisplayError "Your old password was not correct!";
+ } # if
+ } # if
+
+ if (UpdateUser ($userid, $fullname, $email, $new_password) != 0) {
+ DisplayError "Unable to update user record for user $userid";
+ } # if
+
+ if (UpdateUserOptions ($userid, %options) != 0) {
+ DisplayError "Unable to update user options for user $userid";
+ } # if
+
+ print h2 {-class => "header",
+ -align => "center"},
+ "${Userid}'s profile has been updated";
+} # Body
+
+$userid = Heading (
+ "getcookie",
+ "",
+ "Update Profile",
+ "Update user's profile"
+);
+$Userid = ucfirst $userid;
+SetContext $userid;
+NavigationBar $userid;
+Body;
+Footing;
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: $RCSfile: weed,v $
+# Revision: $Revision: 1.1 $
+# Description: Weed out obvious spams from the mail store
+# Author: Andrew@DeFaria.com
+# Created: Mon Feb 19 22:37:30 CST 2007
+# Modified: $Date: 2013/06/12 14:05:47 $
+# Language: perl
+#
+# (c) Copyright 2007, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+use strict;
+use warnings;
+
+use lib $FindBin::Bin, '/opt/clearscm/lib';
+
+use Getopt::Long;
+
+use MAPS;
+
+use Display;
+use Utils;
+
+my $mailstore = "/var/spool/exim/input";
+
+sub Usage {
+ display "Usage: weed: [ -v|erbose ] [ -d|ebug ]\n";
+ display "Where:";
+ display " -v|erbose\tTurn on verbose mode (default off)";
+ display " -d|ebug\tTurn on debug mode (default off)";
+ display " -u|sage\tDisplay this usage message";
+ exit 1;
+} # usage
+
+# Just me
+my $userid = "andrew";
+
+my ($username, $user_email) = SetContext $userid;
+
+sub GetEmailsInSpool () {
+ my %emails;
+
+ # Open mailstore directory. Note must have read access to this
+ # directory and the files in this directory. IOW we probably need to
+ # be running as root. Also, the MTA should not be running because we
+ # may be removing files...
+ opendir MAILSTORE, $mailstore
+ or error "Unable to open mailstore $mailstore - $!", 1;
+
+ # Weed out . and ..
+ my @msgs = grep {!/^\./} readdir MAILSTORE;
+
+ # Don't need the directory opened anymore...
+ closedir MAILSTORE;
+
+ # Select only the "-H" header files...
+ @msgs = grep {/-H$/} @msgs;
+
+ # Now search for "From:" in the header files, extract email address
+ # and put into return hash.
+ my $msg_nbr;
+
+ foreach (@msgs) {
+ $msg_nbr = $_;
+
+ my @lines = ReadFile "$mailstore/$msg_nbr";
+
+ foreach (@lines) {
+ if (/From:\s*(.*)/) {
+ my $sender = $1;
+
+ if ($sender =~ /<(\S*)@(\S*)>/) {
+ $sender = lc ("$1\@$2");
+ } elsif ($sender =~ /(\S*)@(\S*)\ /) {
+ $sender = lc ("$1\@$2");
+ } elsif ($sender =~ /(\S*)@(\S*)/) {
+ $sender = lc ("$1\@$2");
+ } # if
+
+ $emails {$msg_nbr} = $sender;
+ } # if
+ } # foreach
+ } # foreach
+
+ verbose scalar (keys (%emails)) . " emails to process";
+
+ return %emails;
+} # GetEmailsInSpool
+
+sub RemoveEmailInSpool ($) {
+ my ($msg_nbr) = @_;
+
+ my $datafile = "$mailstore/${msg_nbr}-D";
+ my $header_file = "$mailstore/${msg_nbr}-H";
+ my $j_file = "$mailstore/${msg_nbr}-J";
+
+ if (-f $datafile) {
+ unlink $datafile
+ or error "Unable to unlink $datafile - $!";
+ } # if
+
+ if (-f $header_file) {
+ unlink $header_file
+ or error "Unable to unlink $header_file - $!";
+ } # if
+
+ if (-f $j_file) {
+ unlink $j_file
+ or error "Unable to unlink $j_file - $!";
+ } # if
+} # RemoveEmailInSpool
+
+sub FilterEmails (%) {
+ my %emails= @_;
+
+ my $removed = 0;
+
+ foreach (sort (keys (%emails))) {
+ my $msg_nbr;
+
+ if (/(\S+)-H$/) {
+ $msg_nbr = $1;
+ } # if
+
+ my $sender = $emails {"${msg_nbr}-H"};
+
+ if ($sender eq "maps\@defaria.com" ||
+ $sender eq "mailer-daemon\@defaria.com" ||
+ $sender =~ /^defaria.*\@defaria.com$/) {
+ verbose "Removing email $msg_nbr with sender of $sender";
+ RemoveEmailInSpool $msg_nbr;
+ $removed++;
+
+# Need to get $sender_long. Should call ReadMsg from maps. Have to
+# reorganize how this program flows...
+#
+# } elsif ($sender eq $user_email and
+# (lc ($sender_long) !~ lc ("\"$username\" <$user_email>") and
+# lc ($sender_long) !~ lc ("$username <$user_email>"))) {
+# RemoveEmailInSpool $msg_nbr;
+# $removed++;
+ } elsif (OnNulllist $sender) {
+ verbose "Nulllist $msg_nbr ($sender)";
+
+ Nulllist $sender;
+ RemoveEmailInSpool $msg_nbr;
+ $removed++;
+ } # if
+ } # foreach
+
+ return $removed;
+} # FilterEmails
+# Main
+
+my %opts;
+my $result = GetOptions (\%opts,
+ "usage" => sub { Usage },
+ "verbose" => sub { set_verbose },
+ "debug" => sub { set_debug },
+ );
+
+my $removed = FilterEmails (GetEmailsInSpool ());
+
+verbose "$removed emails removed from the mail store";
+
+exit;
--- /dev/null
+<!doctype html public "-//w3c//dtd html 4.01 transitional//en">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html;charset=ISO-8859-1">
+ <link rel="stylesheet" type="text/css" href="http://defaria.com/maps/css/MAPSPlain.css">
+ <title>MAPS Black list</title>
+</head>
+
+<body>
+
+<h1 align="center"><font color="#ff0000">Mail Authorization and Permission System (MAPS)</font></h1>
+
+<h2 align="center"><font color=black>You've been blacklisted!</font></h2>
+
+<p>Sorry but I am no longer accepting email from your email address. You've
+been blacklisted. This can be because you've abused the privilege of being
+able to email me by sending me SPAM or you have otherwise offended me
+personally. Your email is discarded and this message is sent to you in an
+effort to inform you that continued attempts to email me is fruitless.</p>
+
+<div class="copyright">
+
+Copyright © 2001-2006 - All rights reserved<br>
+
+<a href="http://defaria.com/">Andrew DeFaria</a> <a
+href="mailto:Andrew@DeFaria.com"><Andrew@DeFaria.com></a>
+
+</div>
+
+</body>
+</html>
--- /dev/null
+/************************************************************************/
+/* File: MAPSPlain.css */
+/* Description: Cascading Style Sheet definitions for MAPS (plain */
+/* version) */
+/* Author: Andrew@DeFaria.com */
+/* Created: Mon Nov 3 21:55:05 PST 2003 */
+/* Language: Cascading Style Sheet */
+/* */
+/* (c) Copyright 2003, Andrew@DeFaria.com, all rights reserved. */
+/************************************************************************/
+body {
+ background-color: white;
+ color: #000066;
+ font-family: trebuchet MS,
+ trebuchet,
+ verdana,
+ arial,
+ sans-serif;
+ font-size: 16px;
+ margin: 10px;
+}
+
+.heading {
+ margin-left: 140px;
+ margin-top: 5px;
+ padding: 5px;
+}
+
+.leftbar {
+ height: auto;
+ left: 2px;
+ position: absolute;
+ top: 5px;
+ width: 135px;
+}
+
+.username {
+ color: white;
+ font-family: veranda, arial;
+ font-style: bold;
+ font-size: 14px;
+ margin-left: 2px;
+ margin-bottom: 5px;
+ text-align: center;
+ width: 125px;
+}
+
+.menu {
+ background-color: #579;
+ background-image: url(/maps/images/world.gif);
+ border: 2px groove black;
+ font-family: verdana, geneva, arial, helvetica, sans-serif;
+ font-size: 14px;
+ font-weight: bold;
+ line-height: 150%;
+ margin: 2px;
+ padding: 2px;
+ width: 122px;
+}
+
+.intromenu {
+ background-color: #579;
+ border: 2px groove black;
+ font-family: verdana, geneva, arial, helvetica, sans-serif;
+ font-size: 14px;
+ font-weight: bold;
+ line-height: 150%;
+ margin: 2px;
+ padding: 2px;
+ width: 125px;
+}
+
+.search {
+ background: #4682b4;
+ border: 2px groove black;
+ color: white;
+ font-family: veranda, arial;
+ font-style: bold;
+ margin-left: 2px;
+ margin-right: 5px;
+ text-align: center;
+ width: 125px;
+}
+
+.quickstats {
+ background-color: #ffffcc;
+ border: 2px groove #336699;
+ color: black;
+ font-size: 10px;
+ line-height: 10px;
+ margin: 2px;
+ padding: 2;
+ width: 125px;
+}
+
+.content {
+ background: #fff;
+ border: 0.1px solid #fff;
+ color: #666;
+ font-family: trebuchet MS, trebuchet, verdana, arial, sans-serif;
+ margin: 5px;
+ padding: 5px;
+ width: auto;
+}
+
+.copyright {
+ border-bottom: 1px dotted #ccc;
+ border-top: 1px dotted #ccc;
+ color: #666;
+ font-family: verdana, arial, sans-serif;
+ font-size: 10px;
+ margin-top: 5px;
+ text-align: center;
+ width: auto;
+}
+
+.label {
+ color: #993333;
+ font-weight: bold;
+ font-size: 14px;
+}
+
+.smalllabel {
+ color: #993333;
+ font-weight: bold;
+ font-size: 12px;
+}
+
+.smallnumber {
+ color: black;
+ font-size: 12px;
+}
+
+.header {
+ color: #000099;
+ font-weight: bold;
+}
+
+.standout {
+ color: red
+}
+
+.error {
+ color: red;
+ font-style: bold;
+}
+
+.dim {
+ color: #999999;
+}
+
+.dimsmall {
+ color: #999999;
+ font-size: 0.9em;
+ font-family: Times;
+}
+
+.highlite {
+ color: #000099;
+ font-weight: bold;
+}
+
+.inputfield {
+ background: #ece9d8;
+ color: Black;
+ font-family: Veranda,
+ Times;
+ font-size: 12px;
+ padding-top: 0px;
+ padding-bottom: 0px;
+}
+
+.note {
+ background: #339999;
+ color: White;
+ font-weight: bold;
+}
+
+.notetext {
+ color: #333;
+ font-size: 12px;
+ font-weight: italic;
+}
+
+# Headers
+h1, h2, h3, h4, h5 {
+ color: #000099;
+}
+
+h1 {
+ font-size: 18pt;
+}
+
+h2 {
+ font-size: 14pt;
+}
+
+h3 {
+ font-size: 10pt;
+}
+
+h4 {
+ font-size: 8pt;
+}
+
+# Global anchor effects
+a {
+ background: transparent;
+ text-decoration: none;
+}
+
+a:link {
+ color: #0000ee;
+}
+
+a:visited {
+ color: #cc33cc;
+}
+
+a:hover {
+ color: White;
+ background: #0054e3;
+}
+
+a:active {
+ color: #ff0000;
+}
+
+# Special anchor effects
+.sender {
+ font-weight: bold
+}
+
+.sender a:link {
+ color: Red;
+}
+
+.sender a:visited {
+ color: #0054e3;
+}
+
+.sender a:hover {
+ color: White;
+ background: Red;
+}
+
+.sender a:active {
+ color: Yellow;
+}
+
+# Menu anchors
+.menu {
+ font-weight: bold;
+}
+
+.menu a:link {
+ color: Red;
+}
+
+.menu a:visited {
+ color: white;
+}
+
+.menu a:hover {
+ color: White;
+ background: Red;
+}
+
+.menu a:active {
+ color: Yellow;
+}
+
+# Intromenu anchors
+.intromenu {
+ font-weight: bold;
+}
+
+.intromenu a:link {
+ color: Red;
+}
+
+.intromenu a:visited {
+ color: white;
+}
+
+.intromenu a:hover {
+ color: White;
+ background: Red;
+}
+
+.intromenu a:active {
+ color: Yellow;
+}
+
+.leftbox {
+ border: thin silver solid;
+ float: left;
+ width: 25%;
+ margin: 0.5em;
+ padding: 0.5em;
+ background: #f8f8f8;
+ color: black;
+ font-size: 12px;
+ -moz-border-radius: 10px;
+}
+
+.rightbox {
+ border: thin silver solid;
+ float: right;
+ width: 25%;
+ margin: 0.5em;
+ padding: 0.5em;
+ background: #f8f8f8;
+ color: black;
+ font-size: 12px;
+ -moz-border-radius: 10px;
+}
--- /dev/null
+/************************************************************************/
+/* File: MAPSStyle.css */
+/* Description: Cascading Style Sheet definitions for MAPS */
+/* Author: Andrew@DeFaria.com */
+/* Created: Mon Nov 3 21:55:05 PST 2003 */
+/* Language: Cascading Style Sheet */
+/* */
+/* (c) Copyright 2003, Andrew@DeFaria.com, all rights reserved. */
+/************************************************************************/
+body {
+ background-color: #fff;
+ background-image: url(/maps/images/Pattern1.gif);
+ background-repeat: repeat-y;
+ color: black;
+ font-family: trebuchet MS,
+ trebuchet,
+ verdana,
+ arial,
+ sans-serif;
+ font-size: 14px;
+margin: 0px;
+}
+
+.heading {
+margin-left: 140px;
+margin-top: 5px;
+padding: 5px;
+}
+
+#leftbar {
+line-height: 18px;
+height: auto;
+left: 2px;
+position: absolute;
+top: 5px;
+width: 135px;
+}
+
+.username {
+color: white;
+font-family: veranda, arial;
+font-style: bold;
+font-size: 14px;
+margin-left: 2px;
+margin-bottom: 5px;
+text-align: center;
+ width: 125px;
+}
+
+.menu {
+ background-color: #579;
+ background-image: url(/maps/images/world.gif);
+ border: 2px groove black;
+ font-family: verdana, geneva, arial, helvetica, sans-serif;
+ font-size: 14px;
+ font-weight: bold;
+ line-height: 150%;
+ margin: 2px;
+ padding: 2px;
+ width: 122px;
+}
+
+.intromenu {
+ background-color: #579;
+ border: 2px groove black;
+ font-family: verdana, geneva, arial, helvetica, sans-serif;
+ font-size: 14px;
+ font-weight: bold;
+ line-height: 150%;
+ margin: 2px;
+ padding: 2px;
+ width: 125px;
+}
+
+.search {
+ background: #4682b4;
+ border: 2px groove black;
+ color: white;
+ font-family: veranda, arial;
+ font: bold;
+ font-size: 70%;
+ margin-left: 2px;
+ margin-right: 5px;
+ text-align: center;
+ width: 125px;
+}
+
+.quickstats {
+ background-color: #ffffcc;
+ border: 2px groove #336699;
+ color: black;
+ font-size: 10px;
+ line-height: 10px;
+ margin: 2px;
+ width: 125px;
+}
+
+.quickstats a:link {
+ text-decoration: none;
+}
+
+.quickstats a:hover {
+ background: blue;
+ color: white;
+}
+
+.toolbar a:hover {
+ background: transparent;
+}
+
+.content {
+ background: #fff;
+ border: 0.1px solid #fff;
+ color: black;
+ font-family: trebuchet MS,
+ trebuchet,
+ verdana,
+ arial,
+ sans-serif;
+ margin-left: 140px;
+ padding: 5px;
+ width: auto;
+}
+
+.copyright {
+ border-bottom: 1px dotted #ccc;
+ border-top: 1px dotted #ccc;
+ color: #999;
+ font-family: verdana, arial, sans-serif;
+ font-size: 10px;
+ margin-top: 5px;
+ text-align: center;
+ width: auto;
+}
+
+.label {
+ color: #993333;
+ font-weight: bold;
+ font-size: 14px;
+}
+
+.smalllabel {
+ color: #993333;
+ font-weight: bold;
+ line-height: 12px;
+ font-size: 12px;
+}
+
+.smallnumber {
+ color: black;
+ line-height: 12px;
+ font-size: 12px;
+}
+
+.header {
+ color: #000099;
+ line-height: 12px;
+ font-weight: bold;
+}
+
+.standout {
+ color: red;
+}
+
+.found {
+ color: black;
+ background: #ffffcc;
+ font-style: italic;
+}
+
+.error {
+ color: red;
+ font-style: bold;
+}
+
+.dim {
+ color: #999999;
+}
+
+.dimsmall {
+ color: #999999;
+ font-size: 0.9em;
+ font-family: Times;
+}
+
+.highlite {
+ color: #000099;
+ font-weight: bold;
+}
+
+.inputfield {
+ background: #ece9d8;
+ color: Black;
+ font-family: Veranda,
+ Times;
+ font-size: 12px;
+ padding-top: 0px;
+ padding-bottom: 0px;
+}
+
+#searchfield {
+ font-size: 95%;
+ font-weight: normal;
+ background: #4693c5;
+ border: solid 1px #00507d;
+ border-bottom-color: #007de1;
+ border-right-color: #007de1;
+ width: 90%
+}
+#searchfield:hover {
+ background: #c3e1ff;
+}
+#searchfield:focus {
+ background: white;
+}
+
+.note {
+ background: #339999;
+ color: White;
+ font-weight: bold;
+}
+
+.notetext {
+ color: #333;
+ font-size: 10px;
+ font-weight: italic;
+}
+
+/* Headers */
+h1, h2, h3, h4, h5 {
+ color: #000099;
+}
+
+h1 {
+ font-size: 18pt;
+}
+
+h2 {
+ font-size: 14pt;
+}
+
+h3 {
+ font-size: 10pt;
+}
+
+h4 {
+ font-size: 8pt;
+}
+
+/* Global anchor effects */
+a {
+ background: transparent;
+ text-decoration: none;
+}
+
+a:link {
+ color: #0080c0;
+/* color: #0000ee; */
+}
+
+a:visited {
+ color: #cc3300;
+}
+
+a:hover {
+ color: blue;
+ background: #ffff80;
+}
+
+a:active {
+ color: #ff0000;
+}
+
+img {
+ border: none;
+}
+
+/* Table colors */
+.tableleftend {
+ background: #804000;
+ color: white;
+ font-style: bold;
+ font-size: 14;
+ text-align: center;
+ -moz-border-radius-topleft: 7px;
+ border-top-left-radius: 7px;
+}
+.tablerightend {
+ background: #804000;
+ color: white;
+ font-style: bold;
+ font-size: 14;
+ text-align: center;
+ -moz-border-radius-topright: 7px;
+ border-top-right-radius: 7px;
+}
+
+.tablebordertopleft {
+ background: #804000;
+ color: white;
+ font-style: bold;
+ font-size: 14;
+ text-align: center;
+ -moz-border-radius-topleft: 7px;
+ border-top-left-radius: 7px;
+}
+
+.tablebordertopright {
+ background: #804000;
+ color: white;
+ font-style: bold;
+ font-size: 14;
+ text-align: center;
+ -moz-border-radius-topright: 7px;
+ border-top-right-radius: 7px;
+}
+
+.tableborderbottomleft {
+ background: #804000;
+ color: white;
+ font-style: bold;
+ font-size: 14;
+ text-align: center;
+ -moz-border-radius-bottomleft: 7px;
+ border-bottom-left-radius: 7px;
+}
+
+.tableborderbottomright {
+ background: #804000;
+ color: white;
+ font-style: bold;
+ font-size: 14;
+ text-align: center;
+ -moz-border-radius-bottomright: 7px;
+ border-bottom-right-radius: 7px;
+}
+
+.tableborder {
+ background: #804000;
+ color: white;
+ font-style: bold;
+ font-size: 14;
+ text-align: center;
+}
+
+.tablebordertopleft a:hover {
+ background: transparent;
+}
+
+.tablebordertopright a:hover {
+ background: transparent;
+}
+
+.tableborderbottomleft a:hover {
+ background: transparent;
+}
+
+.tableborderbottomright a:hover {
+ background: transparent;
+}
+
+.tablelabel {
+ background: #ece9d8;
+ text-align: right;
+ font-family: arial, sans-serif;
+ font-size: 10px;
+ font-weight: bold;
+ -moz-border-radius: 7px;
+ border-radius: 7px;
+}
+
+.tableheader {
+ background: #804000;
+ color: white;
+ text-align: center;
+ font-family: arial, sans-serif;
+ font-size: 14px;
+ font-weight: bold;
+}
+
+.msgtable {
+ background: #d4d0c8;
+}
+
+.msgnbr {
+ font-size: 8px;
+ text-align: center;
+}
+
+.tableleftdata {
+ background: #ffffee;
+ border-left: solid 3px #804000;
+ border-bottom: 1px dotted #ccc;
+ font-size: 14;
+}
+.tableleftrightdata {
+ background: #ece9d8;
+ border-right: solid 3px #804000;
+ border-left: solid 1px #804000;
+ border-bottom: 1px dotted #ccc;
+ font-size: 14;
+}
+.tablerightleftdata {
+ background: #ece9d8;
+ border-right: solid 1px #804000;
+ border-left: solid 3px #804000;
+ border-bottom: 1px dotted #ccc;
+ font-size: 14;
+}
+.tablerightdata {
+ background: #ffffee;
+ border-right: solid 3px #804000;
+ border-left: 1px dotted #ccc;
+ border-bottom: 1px dotted #ccc;
+ font-size: 14;
+}
+.tablebottomleft {
+ background: #ffffee;
+ border-left: solid 3px #804000;
+ border-right: 1px dotted #ccc;
+ border-bottom: solid 3px #804000;
+ font-size: 14;
+ -moz-border-radius-bottomleft: 7px;
+ border-bottom-left-radius: 7px;
+}
+.tablebottomright {
+ background: #ffffee;
+ border-right: solid 3px #804000;
+ border-left: 1px dotted #ccc;
+ border-bottom: solid 3px #804000;
+ font-size: 14;
+ -moz-border-radius-bottomright: 7px;
+ border-bottom-right-radius: 7px;
+}
+.tablebottomdata {
+ background: #ffffee;
+ border-left: 1px dotted #ccc;
+ border-bottom: solid 3px #804000;
+ font-size: 14;
+}
+.tablebottomlefttotal {
+ background: #ece9d8;
+ border-left: solid 3px #804000;
+ border-bottom: solid 3px #804000;
+ border-right: 1px dotted #ccc;
+ font-size: 14;
+ -moz-border-radius-bottomleft: 7px;
+ border-bottom-left-radius: 7px;
+}
+.tablebottomrighttotal {
+ background: #ece9d8;
+ border-right: solid 3px #804000;
+ border-bottom: solid 3px #804000;
+ font-size: 14;
+ -moz-border-radius-bottomright: 7px;
+ border-bottom-right-radius: 7px;
+}
+.tablebottomtotal {
+ background: #ece9d8;
+ border-bottom: solid 3px #804000;
+ border-top: solid 1px #804000;
+ border-right: 1px dotted #ccc;
+ font-size: 14;
+}
+.tabledata {
+ background: #ffffee;
+ border-left: 1px dotted #ccc;
+ border-bottom: 1px dotted #ccc;
+ font-size: 14;
+}
+
+.date {
+ background: #ffffee;
+ font-size: 10px;
+}
+
+.dateright {
+ background: #ffffee;
+ font-size: 10px;
+ border-right: solid 3px #804000;
+ border-left: 1px dotted #ccc;
+ border-bottom: 1px dotted #ccc;
+}
+
+/* Special anchor effects */
+.sender {
+ background: #ffffee;
+ font-family: arial, sans-serif;
+ font-size: 12px;
+ font-weight: bold;
+}
+
+.sender a:link {
+ color: Red;
+}
+
+.sender a:visited {
+ color: #0054e3;
+}
+
+.sender a:hover {
+ color: White;
+ background: Red;
+}
+
+.sender a:active {
+ color: Yellow;
+}
+
+.subject {
+ background: #ffffee;
+ font-family: arial, sans-serif;
+ font-size: 10px;
+ font-weight: bold;
+}
+
+.subject a:link {
+ color: #0000ee;
+}
+
+.subject a:visited {
+ color: #cc33cc;
+}
+
+.subject a:hover {
+ color: White;
+ background: #0054e3;
+}
+
+.subject a:active {
+ color: #ff0000;
+}
+
+/* Menu anchors */
+.menu {
+ font-weight: bold;
+}
+
+.menu a:link {
+ color: White;
+ text-decoration: none;
+}
+
+.menu a:visited {
+ color: white;
+}
+
+.menu a:hover {
+ color: Yellow;
+ background: none;
+}
+
+.menu a:active {
+ color: Yellow;
+}
+
+/* Intromenu anchors */
+.intromenu {
+ font-weight: bold;
+}
+
+.intromenu a:link {
+ color: Red;
+}
+
+.intromenu a:visited {
+ color: white;
+}
+
+.intromenu a:hover {
+ color: White;
+ background: Red;
+}
+
+.intromenu a:active {
+ color: Yellow;
+}
--- /dev/null
+<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">\r
+<html>\r
+<head>\r
+ <title>MAPS: How does it work?</title>\r
+ \r
+ <meta http-equiv="content-type"\r
+ content="text/html; charset=ISO-8859-1">\r
+ \r
+ <meta name="author" content="Andrew DeFaria">\r
+</head>\r
+<body text="#000000" bgcolor="#33ccff" link="#000099" vlink="#990099"\r
+ alink="#000099">\r
+<script language="JavaScript1.2" src="JavaScript/Heading.js"></script> \r
+<h3 align=center>Unfinished Item</h3>\r
+<center><img src="/Images/Comingsoon.jpg"></center>\r
+<script language="JavaScript1.2" SRC="JavaScript/Footing.js"></script>\r
--- /dev/null
+<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">\r
+<html>\r
+<head>\r
+ <title>MAPS: How does it work?</title>\r
+ \r
+ <meta http-equiv="content-type"\r
+ content="text/html; charset=ISO-8859-1">\r
+ \r
+ <meta name="author" content="Andrew DeFaria">\r
+</head>\r
+<body text="#000000" bgcolor="#33ccff" link="#000099" vlink="#990099"\r
+ alink="#000099">\r
+<script language="JavaScript1.2" src="JavaScript/Heading.js"></script> \r
+<h3 align=center>Unfinished Item</h3>\r
+<center><img src="/Images/Comingsoon.jpg"></center>\r
+<script language="JavaScript1.2" SRC="JavaScript/Footing.js"></script>\r
--- /dev/null
+<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">\r
+<html>\r
+<head>\r
+ <title>MAPS: How does it work?</title>\r
+ \r
+ <meta http-equiv="content-type"\r
+ content="text/html; charset=ISO-8859-1">\r
+ \r
+ <meta name="author" content="Andrew DeFaria">\r
+</head>\r
+<body text="#000000" bgcolor="#33ccff" link="#000099" vlink="#990099"\r
+ alink="#000099">\r
+<script language="JavaScript1.2" src="JavaScript/Heading.js"></script> \r
+<h3 align=center>Unfinished Item</h3>\r
+<center><img src="/Images/Comingsoon.jpg"></center>\r
+<script language="JavaScript1.2" SRC="JavaScript/Footing.js"></script>\r
--- /dev/null
+<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">\r
+<html>\r
+<head>\r
+ <title>MAPS: How does it work?</title>\r
+ \r
+ <meta http-equiv="content-type"\r
+ content="text/html; charset=ISO-8859-1">\r
+ \r
+ <meta name="author" content="Andrew DeFaria">\r
+</head>\r
+<body text="#000000" bgcolor="#33ccff" link="#000099" vlink="#990099"\r
+ alink="#000099">\r
+<script language="JavaScript1.2" src="JavaScript/Heading.js"></script> \r
+<h3 align=center>Unfinished Item</h3>\r
+<center><img src="/Images/Comingsoon.jpg"></center>\r
+<script language="JavaScript1.2" SRC="JavaScript/Footing.js"></script>\r
--- /dev/null
+<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">\r
+<html>\r
+<head>\r
+ <title>MAPS: How does it work?</title>\r
+ \r
+ <meta http-equiv="content-type"\r
+ content="text/html; charset=ISO-8859-1">\r
+ \r
+ <meta name="author" content="Andrew DeFaria">\r
+</head>\r
+<body text="#000000" bgcolor="#33ccff" link="#000099" vlink="#990099"\r
+ alink="#000099">\r
+<script language="JavaScript1.2" src="JavaScript/Heading.js"></script> \r
+<h3 align=center>Unfinished Item</h3>\r
+<center><img src="/Images/Comingsoon.jpg"></center>\r
+<script language="JavaScript1.2" SRC="JavaScript/Footing.js"></script>\r
--- /dev/null
+<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">\r
+<html>\r
+<head>\r
+ <title>MAPS: How does it work?</title>\r
+ \r
+ <meta http-equiv="content-type"\r
+ content="text/html; charset=ISO-8859-1">\r
+ \r
+ <meta name="author" content="Andrew DeFaria">\r
+</head>\r
+<body text="#000000" bgcolor="#33ccff" link="#000099" vlink="#990099"\r
+ alink="#000099">\r
+<script language="JavaScript1.2" src="JavaScript/Heading.js"></script> \r
+<h3 align=center>Unfinished Item</h3>\r
+<center><img src="/Images/Comingsoon.jpg"></center>\r
+<script language="JavaScript1.2" SRC="JavaScript/Footing.js"></script>\r
--- /dev/null
+<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">\r
+<html>\r
+<head>\r
+ <title>MAPS: How does it work?</title>\r
+ \r
+ <meta http-equiv="content-type"\r
+ content="text/html; charset=ISO-8859-1">\r
+ \r
+ <meta name="author" content="Andrew DeFaria">\r
+</head>\r
+<body text="#000000" bgcolor="#33ccff" link="#000099" vlink="#990099"\r
+ alink="#000099">\r
+<script language="JavaScript1.2" src="JavaScript/Heading.js"></script> \r
+<h3 align=center>Unfinished Item</h3>\r
+<center><img src="/Images/Comingsoon.jpg"></center>\r
+<script language="JavaScript1.2" SRC="JavaScript/Footing.js"></script>\r
--- /dev/null
+<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">\r
+<html>\r
+<head>\r
+ <title>Mail Authorization and Permission System</title>\r
+ <meta http-equiv="content-type" content="text/html; charset=ISO-8859-1">\r
+ <meta name="author" content="Andrew DeFaria">\r
+</head>\r
+ <body alink="#000099" vlink="#990099" link="#000099" bgcolor="#33ccff"\r
+ text="#000000">\r
+<script language="JavaScript1.2" src="JavaScript/Heading.js"></script>\r
+<h1><font color="#000099">Null List</font></h1>\r
+<p>First the null list. As you know sending a message back to a potential \r
+spammer will often not work. Many times their return addresses are fake or \r
+their mail boxes are full. The spammers ISP will often send a message back to \r
+you to tell you that the email address is invalid or the user's mail box is \r
+full. You don't care about these messages and they would only create more spam,\r
+though not commerical junk email - unwanted email nonetheless. So you add email\r
+addresses to your null list to tell MAPS to just discard these messages. \r
+Entries in your null list can be generic in nature. For example, "mail-daemon"\r
+is a common string in a bounced email address from an ISP. Entering \r
+"mail-daemon" will discard messages from mail-daemon@aol.com as well as\r
+mail-daemon@msn.com. Most users do not care to receive email messages from\r
+mailer daemons.</p>\r
+<h1><font color="#000099">Black List</font></h1>\r
+<p>The black list is for people who you are effectively ignoring. It works\r
+similarly to null lists except that a message telling the sender that you are\r
+ignoring them is returned to the sender. Use this when you want to make sure \r
+the sender knows that you are ignoring them.</p>\r
+<h1><font color="#000099">White List</font></h1>\r
+<p>The white list is the list of people who are allowed to email you. \r
+Management of the white list is up to the people who wish to email you, thus\r
+you are not bothered by the hassle of having to maintain a white list. You\r
+can manage your white list, pre-registering a user or say initializing your\r
+white list from your addressbook (called Seeding your White List). But by and\r
+large the white list will be managed by your legitimate email subscribers.\r
+<script language="JavaScript1.2" src="JavaScript/Footing.js"></script>\r
+</body>\r
+</html>\r
--- /dev/null
+<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">\r
+<html>\r
+<head>\r
+ <title>MAPS: How does it work?</title>\r
+ \r
+ <meta http-equiv="content-type"\r
+ content="text/html; charset=ISO-8859-1">\r
+ \r
+ <meta name="author" content="Andrew DeFaria">\r
+</head>\r
+<body text="#000000" bgcolor="#33ccff" link="#000099" vlink="#990099"\r
+ alink="#000099">\r
+<script language="JavaScript1.2" src="JavaScript/Heading.js"></script> \r
+<h3 align=center>Unfinished Item</h3>\r
+<center><img src="/Images/Comingsoon.jpg"></center>\r
+<script language="JavaScript1.2" SRC="JavaScript/Footing.js"></script>\r
--- /dev/null
+<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">\r
+<html>\r
+<head>\r
+ <title>MAPS: How does it work?</title>\r
+ \r
+ <meta http-equiv="content-type"\r
+ content="text/html; charset=ISO-8859-1">\r
+ \r
+ <meta name="author" content="Andrew DeFaria">\r
+</head>\r
+<body text="#000000" bgcolor="#33ccff" link="#000099" vlink="#990099"\r
+ alink="#000099">\r
+<script language="JavaScript1.2" src="JavaScript/Heading.js"></script> \r
+<h3 align=center>Unfinished Item</h3>\r
+<center><img src="/Images/Comingsoon.jpg"></center>\r
+<script language="JavaScript1.2" SRC="JavaScript/Footing.js"></script>\r
--- /dev/null
+<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">\r
+<html>\r
+<head>\r
+ <title>MAPS: How does it work?</title>\r
+ \r
+ <meta http-equiv="content-type"\r
+ content="text/html; charset=ISO-8859-1">\r
+ \r
+ <meta name="author" content="Andrew DeFaria">\r
+</head>\r
+<body text="#000000" bgcolor="#33ccff" link="#000099" vlink="#990099"\r
+ alink="#000099">\r
+<script language="JavaScript1.2" src="JavaScript/Heading.js"></script> \r
+<h3 align=center>Unfinished Item</h3>\r
+<center><img src="/Images/Comingsoon.jpg"></center>\r
+<script language="JavaScript1.2" SRC="JavaScript/Footing.js"></script>\r
--- /dev/null
+<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">\r
+<html>\r
+<head>\r
+ <title>MAPS: How does it work?</title>\r
+ \r
+ <meta http-equiv="content-type"\r
+ content="text/html; charset=ISO-8859-1">\r
+ \r
+ <meta name="author" content="Andrew DeFaria">\r
+</head>\r
+<body text="#000000" bgcolor="#33ccff" link="#000099" vlink="#990099"\r
+ alink="#000099">\r
+<script language="JavaScript1.2" src="JavaScript/Heading.js"></script> \r
+<h3 align=center>Unfinished Item</h3>\r
+<center><img src="/Images/Comingsoon.jpg"></center>\r
+<script language="JavaScript1.2" SRC="JavaScript/Footing.js"></script>\r
--- /dev/null
+<?php \r
+include "site-functions.php";\r
+include "MAPS.php"\r
+?>\r
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">\r
+<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US">\r
+<head>\r
+ <title>MAPS: Requirements</title>\r
+ <?php MAPSHeader ()?>\r
+</head>\r
+<body>\r
+\r
+<div class="heading">\r
+ <h2 class="header" align="center">\r
+ <font class="standout">MAPS</font> Requirements</h2>\r
+</div>\r
+\r
+<div class="content">\r
+ <?php \r
+ OpenDB ();\r
+ SetContext ($userid);\r
+ NavigationBar ($userid);\r
+ ?>\r
+\r
+ <h3>Requirements</h3>\r
+\r
+ <p>Requirements for MAPS are minimal. All you need is to do is to <a\r
+ href="/maps/SignupForm.html">Signup</a> for a MAPS account. Other\r
+ than that we believe that you local email client is the best way of\r
+ reading and handling your email. Any email client that supports POP\r
+ will work. If you use MAPS as your email server then you would\r
+ configure your email client to POP off of defaria.com. Alternately\r
+ you can use <a href="MAPSPop.html">MAPSPOP</a> to retrieve your\r
+ email from any email address but filter it through MAPS.</p>\r
+\r
+ <p>Additionally you can visit the <a href="/maps">MAPS</a> web site\r
+ to view spam activity, manage your <i>white</i>, <i>black</i> and\r
+ <i>null</i> lists.</p>\r
+\r
+ <?php copyright (2001);?>\r
+\r
+ </div>\r
+</body>\r
+</html>\r
--- /dev/null
+<?php \r
+include "site-functions.php";\r
+include "MAPS.php"\r
+?>\r
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">\r
+<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US">\r
+<head>\r
+ <title>MAPS: What is SPAM?</title>\r
+ <?php MAPSHeader ()?>\r
+</head>\r
+<body>\r
+\r
+<div class="heading">\r
+ <h2 class="header" align="center">\r
+ <font class="standout">MAPS</font> What is SPAM?</h2>\r
+</div>\r
+\r
+<div class="content">\r
+ <?php \r
+ OpenDB ();\r
+ SetContext ($userid);\r
+ NavigationBar ($userid);\r
+ ?>\r
+\r
+ <h3>What is SPAM?</h3>\r
+\r
+ <p>SPAM, also known as unsolicited email, has many definitions to\r
+ many people. Some people consider it only unsolicited commerical\r
+ email - the kind of email that is trying to sell you\r
+ something. Others consider it any email that you did not wish to\r
+ see. MAPS does not really attempt to define SPAM rather it simply\r
+ classifies email as either permitted or not. Initially all email is\r
+ considered not permitted. It is only when others register for\r
+ permission to email you that MAPS considers email as <i>wanted</i>.</p>\r
+\r
+ <p>Initially all email will be returned to the sender with a message\r
+ that describes how to register for permission to email you. Returned\r
+ email is saved for up to 30 days (configurable) so that if the\r
+ sender decides to register their previous email(s) will be\r
+ delivered. If they register then all previous emails will be\r
+ delivered and they will be added to your white list. Future emails\r
+ from them will be delivered instead of returned.</p>\r
+\r
+ <p>Typically spammers are really robots or scripts that send\r
+ thousands or millions of emails to address lists. They don't read\r
+ returned messages so they will not register for permission to email\r
+ you. Occasionally a spammer, usually a small operation, will read\r
+ the returned message and may register. If this happens then you can\r
+ easily <i>blacklist</i> that spammer and not be bothered by them\r
+ again. As a MAPS user myself who receives probably more SPAM than\r
+ you will ever see I can say that perhaps one to two real spammers\r
+ will register every other month. So you can easily deal with such\r
+ annoyances.</p>\r
+\r
+ <p>Because spammers often use invalid email addresses or email\r
+ address that quickly fill up with "Please don't bother me" return\r
+ messages, often a MAPS register message will be returned by a\r
+ <i>mailer daemon</i> telling you that the spammer's email address\r
+ doesn't exist or is full. You don't want to be bothered with such\r
+ return messages so MAPS seeds your <i>null list</i> with entries to\r
+ prevent this. If you receive emails from such mailer daemons and do\r
+ not wish to receive them simply null list them. The <i>null list</i>\r
+ is also good for other annoying email that you receive that you'd\r
+ rather not be bothered with. For example, you might receive a\r
+ newsletter sort of email from a company you normally wish to deal\r
+ with but are not really interested in their newsletters. Perhaps the\r
+ newsletters are send from an address of\r
+ <i>newsletters@<company I care about>.com</i> where\r
+ other email might come from <i>support@<company I care\r
+ about>.com</i>. In that case you can safely null list\r
+ <i>newsletters@<company I care about>.com</i>. For\r
+ exmaple, I null list <i>discship@netflix.com</i> because I\r
+ do not wish to receive those information emails from <a\r
+ href="http://netflix.com">Netflix.com</a> about shipments.</p>\r
+\r
+ <p>Your <i>black list</i> is similar to your <i>null list</i> except\r
+ instead of merely discarding the email, a return message is sent to\r
+ the sender saying that they are blacklisted. This is good for people\r
+ who you wish to make sure know that you are consciously ignoring\r
+ them.</p>\r
+\r
+ <?php copyright (2001);?>\r
+\r
+ </div>\r
+</body>\r
+</html>\r
--- /dev/null
+<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">\r
+<html>\r
+<head>\r
+ <title>MAPS: How does it work?</title>\r
+ \r
+ <meta http-equiv="content-type"\r
+ content="text/html; charset=ISO-8859-1">\r
+ \r
+ <meta name="author" content="Andrew DeFaria">\r
+</head>\r
+<body text="#000000" bgcolor="#33ccff" link="#000099" vlink="#990099"\r
+ alink="#000099">\r
+<script language="JavaScript1.2" src="JavaScript/Heading.js"></script> \r
+<h3 align=center>Unfinished Item</h3>\r
+<center><img src="/Images/Comingsoon.jpg"></center>\r
+<script language="JavaScript1.2" SRC="JavaScript/Footing.js"></script>\r
--- /dev/null
+<?php \r
+include "site-functions.php";\r
+include "MAPS.php"\r
+?>\r
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">\r
+<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US">\r
+<head>\r
+ <title>MAPS: Using</title>\r
+ <?php MAPSHeader ()?>\r
+</head>\r
+<body>\r
+\r
+<div class="heading">\r
+ <h2 class="header" align="center">\r
+ <font class="standout">MAPS</font> Using</h2>\r
+</div>\r
+\r
+<div class="content">\r
+ <?php \r
+ OpenDB ();\r
+ SetContext ($userid);\r
+ NavigationBar ($userid);\r
+ ?>\r
+\r
+ <h3>Using MAPS</h3>\r
+\r
+ <p>To be completed...</p>\r
+\r
+ <?php copyright (2001);?>\r
+\r
+ </div>\r
+</body>\r
+</html>\r
--- /dev/null
+<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">\r
+<html>\r
+<head>\r
+ <title>MAPS: How does it work?</title>\r
+ \r
+ <meta http-equiv="content-type"\r
+ content="text/html; charset=ISO-8859-1">\r
+ \r
+ <meta name="author" content="Andrew DeFaria">\r
+</head>\r
+<body text="#000000" bgcolor="#33ccff" link="#000099" vlink="#990099"\r
+ alink="#000099">\r
+<script language="JavaScript1.2" src="JavaScript/Heading.js"></script> \r
+<h3 align=center>Unfinished Item</h3>\r
+<center><img src="/Images/Comingsoon.jpg"></center>\r
+<script language="JavaScript1.2" SRC="JavaScript/Footing.js"></script>\r
--- /dev/null
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">\r
+<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US">\r
+<head>\r
+ <title>MAPS Add to Black List</title>\r
+ \r
+ <link rev="made" href="mailto:Andrew%40DeFaria.com">\r
+ \r
+ <script language="JavaScript1.2" src="checkform.js"\r
+ type="text/javascript"></script>\r
+</head>\r
+ <body link="#0000ee" alink="#ff0000" vlink="#cc33cc" bgcolor="#33ccff">\r
+ \r
+<h2 align="center">MAPS: Add to Black List<br>\r
+ </h2>\r
+ This screen allows you to add to your black list. Note that regular expressions\r
+ can be used so you can modify the <b>Email address</b> below to be any\r
+portion thereof or specify a regular expression. Here are some examples.\r
+Given an email address of Spammer@spamdomain.com you can:<br>\r
+ \r
+<ul>\r
+ <li>Specify just the domain (e.g. @spamdomain.com). This will effectively\r
+ black list everybody from that domain.</li>\r
+ <li>Specify just the username portion (e.g. Spammer@). This will effectively\r
+ black list anybody using the username of spammer (note that email addresses\r
+are <b>not</b> case sensitive) from any domain.</li>\r
+ <li>Use regular expression characters to further refine your filter.\r
+ For example, "^spammer.*@" means any email address that starts (^) with\r
+the word "spammer", has any number of characters after (.*), then an "@"\r
+sign will be black listed.</li>\r
+ \r
+</ul>\r
+ \r
+<table cellpadding="2" cellspacing="0" border="0" width="50%"\r
+ align="center" bgcolor="Red">\r
+ <tbody>\r
+ <tr>\r
+ <td valign="top"> \r
+ <table cellpadding="2" cellspacing="0" border="0" width="100%"\r
+ rules="rows" bgcolor="White">\r
+ <tbody>\r
+ <tr align="center">\r
+ <th valign="top" bgcolor="#ff0000"><big><font\r
+ color="#ffffff">Warning</font></big><br>\r
+ </th>\r
+ </tr>\r
+ <tr>\r
+ <td valign="top"><small>Care should be taken when using regular\r
+ expressions as you can easily black list email messages you do not want\r
+to have blacklisted</small>!<br>\r
+ </td>\r
+ </tr>\r
+ \r
+ </tbody> \r
+ </table>\r
+ </td>\r
+ </tr>\r
+ \r
+ </tbody> \r
+</table>\r
+ <br>\r
+ \r
+<form method="post" action="/maps/bin/register.cgi"\r
+ enctype="application/x-www-form-urlencoded"\r
+ onsubmit="return validate (this);"> \r
+ <table border="0" cellspacing="0" cellpadding="2" width="57%"\r
+ bgcolor="black" align="center">\r
+ <tbody>\r
+ <tr>\r
+ <td> \r
+ <table cellpadding="5" cellspacing="0" border="0" width="100%"\r
+ bgcolor="#ffffcc" cols="2">\r
+ <tbody>\r
+ <tr>\r
+ <td><b>Full name</b> </td>\r
+ <td align="right"><input type="text" name="realname"\r
+ value="" size="50" maxlength="50"> </td>\r
+ </tr>\r
+ <tr>\r
+ <td><b>Email address</b><br>\r
+ </td>\r
+ <td align="right"><input type="text" name="email" value=""\r
+ size="50" maxlength="50"> </td>\r
+ </tr>\r
+ \r
+ </tbody> \r
+ \r
+ </table>\r
+ </td>\r
+ </tr>\r
+ \r
+ </tbody> \r
+ </table>\r
+ \r
+ <center> <input type="submit" name="submit" value="Submit"> </center>\r
+ </form>\r
+ <br>\r
+ <br>\r
+</body>\r
+</html>\r
--- /dev/null
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">\r
+<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US">\r
+<head>\r
+ <title>MAPS Add to Black List</title>\r
+ \r
+ <link rev="made" href="mailto:Andrew%40DeFaria.com">\r
+ \r
+ <script language="JavaScript1.2" src="checkform.js"\r
+ type="text/javascript"></script>\r
+</head>\r
+ <body link="#0000ee" alink="#ff0000" vlink="#cc33cc" bgcolor="#33ccff">\r
+ \r
+<h2 align="center">MAPS: Add to Null List<br>\r
+ </h2>\r
+ This screen allows you to add to your null list. Note that regular expressions\r
+ can be used so you can modify the <b>Email address</b> below to be any\r
+portion thereof or specify a regular expression. Here are some examples.\r
+Given an email address of Spammer@spamdomain.com you can:<br>\r
+ \r
+<ul>\r
+ <li>Specify just the domain (e.g. @spamdomain.com). This will effectively\r
+ discard all email from everybody at that domain.</li>\r
+ <li>Specify just the username portion (e.g. Spammer@). This will effectively\r
+ discard all email from anybody using the username of spammer (note that \r
+email addresses are <b>not</b> case sensitive) from any domain</li>\r
+ <li>Use regular expression characters to further refine your filter.\r
+ For example, "^spammer.*@" means any email from an address that starts\r
+(^) with the word "spammer", has any number of characters after (.*), then\r
+an "@" sign will be discarded.</li>\r
+ \r
+</ul>\r
+ \r
+<table cellpadding="2" cellspacing="0" border="0" width="50%"\r
+ align="center" bgcolor="Red">\r
+ <tbody>\r
+ <tr>\r
+ <td valign="top"> \r
+ <table cellpadding="2" cellspacing="0" border="0" width="100%"\r
+ rules="rows" bgcolor="White">\r
+ <tbody>\r
+ <tr align="center">\r
+ <th valign="top" bgcolor="#ff0000"><big><font\r
+ color="#ffffff">Warning</font></big><br>\r
+ </th>\r
+ </tr>\r
+ <tr>\r
+ <td valign="top"><small>Care should be taken when using regular\r
+ expressions as you can easily lose email messages you do not want to have \r
+discarded!</small><br>\r
+ </td>\r
+ </tr>\r
+ \r
+ </tbody> \r
+ </table>\r
+ </td>\r
+ </tr>\r
+ \r
+ </tbody> \r
+</table>\r
+ <br>\r
+ \r
+<form method="post" action="/maps/bin/register.cgi"\r
+ enctype="application/x-www-form-urlencoded"\r
+ onsubmit="return validate (this);"> \r
+ <table border="0" cellspacing="0" cellpadding="2" width="57%"\r
+ bgcolor="black" align="center">\r
+ <tbody>\r
+ <tr>\r
+ <td> \r
+ <table cellpadding="5" cellspacing="0" border="0" width="100%"\r
+ bgcolor="#ffffcc" cols="2">\r
+ <tbody>\r
+ <tr>\r
+ <td><b>Full name</b> </td>\r
+ <td align="right"><input type="text" name="realname"\r
+ value="" size="50" maxlength="50"> </td>\r
+ </tr>\r
+ <tr>\r
+ <td><b>Email address</b><br>\r
+ </td>\r
+ <td align="right"><input type="text" name="email" value=""\r
+ size="50" maxlength="50"> </td>\r
+ </tr>\r
+ \r
+ </tbody> \r
+ \r
+ </table>\r
+ </td>\r
+ </tr>\r
+ \r
+ </tbody> \r
+ </table>\r
+ \r
+ <center> <input type="submit" name="submit" value="Submit"> </center>\r
+ </form>\r
+ <br>\r
+ <br>\r
+</body>\r
+</html>\r
--- /dev/null
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML Basic 1.0//EN" "http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd">\r
+<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US">\r
+<head>\r
+ <title>Returned Report for Andrew@DeFaria.com</title>\r
+ \r
+ <link rev="made" href="mailto:Andrew%40DeFaria.com">\r
+</head>\r
+ <body text="Black" vlink="#cc33cc" bgcolor="#33ccff" alink="#ff0000"\r
+ link="#0000ee">\r
+ \r
+<h2 align="center">Returned Report for Andrew@DeFaria.com</h2>\r
+ \r
+<table cellpadding="2" cellspacing="0" border="0" width="95%"\r
+ bgcolor="Black" align="center">\r
+ <caption>Note: Only unique email addresses are reported </caption><tbody>\r
+ <tr>\r
+ <td valign="top"> \r
+ <table cellpadding="2" cellspacing="0" border="1" width="100%"\r
+ bgcolor="White">\r
+ <tbody>\r
+ <tr>\r
+ <th valign="top" align="center" bgcolor="#ffffcc"><small>Count<br>\r
+ </small></th>\r
+ <th valign="top" bgcolor="#ffffcc"><small>Email Address<br>\r
+ </small></th>\r
+ <th valign="top" bgcolor="#ffffcc"><small># of Msgs</small><br>\r
+ </th>\r
+ <th valign="top" bgcolor="#ffffcc"><small>Message<br>\r
+ </small></th>\r
+ <th valign="top" bgcolor="#ffffcc"><small>Add to<br>\r
+ </small></th>\r
+ <th valign="top" bgcolor="#ffffcc"><small>Add to<br>\r
+ </small></th>\r
+ <th valign="top" bgcolor="#ffffcc"><small>Add to</small><br>\r
+ </th>\r
+ </tr>\r
+ <tr>\r
+ <td valign="top" align="center"><small>1<br>\r
+ </small></td>\r
+ <td valign="top"><small><a href="mailto:-lee@yahoo.com">-lee@yahoo.com</a><br>\r
+ </small></td>\r
+ <td valign="top" align="center"><small>1<br>\r
+ </small></td>\r
+ <td valign="top" align="center"><small><a\r
+ href="display.cgi?email=-lee@yahoo.com;user=Andrew">Display</a><br>\r
+ </small></td>\r
+ <td valign="top" align="center"><small><a\r
+ href="add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=white.list">White \r
+ list</a><br>\r
+ </small></td>\r
+ <td valign="top" align="center"><small><a\r
+ href="add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=black.list">Black \r
+ List</a><br>\r
+ </small></td>\r
+ <td valign="top" align="center"><small><a\r
+ href="add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=null.list">Null \r
+ List</a><br>\r
+ </small></td>\r
+ </tr>\r
+ <tr>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small>2<br>\r
+ </small></td>\r
+ <td valign="top" bgcolor="#ffffee"><small><a\r
+ href="mailto:1yeq7jft@excite.com">1yeq7jft@excite.com</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small>1<br>\r
+ </small></td>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small><a\r
+ href="http://defaria.com/maps/bin/display.cgi?email=-lee@yahoo.com;user=Andrew">Display</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=white.list">White \r
+ list</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=black.list">Black \r
+ List</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=null.list">Null \r
+ List</a></small><br>\r
+ </td>\r
+ </tr>\r
+ <tr>\r
+ <td valign="top" align="center"><small>3<br>\r
+ </small></td>\r
+ <td valign="top"><small><a href="mailto:235558@wdell.com">235558@wdell.com</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center"><small>2<br>\r
+ </small></td>\r
+ <td valign="top" align="center"><small><a\r
+ href="http://defaria.com/maps/bin/display.cgi?email=-lee@yahoo.com;user=Andrew">Display</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=white.list">White \r
+ list</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=black.list">Black \r
+ List</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=null.list">Null \r
+ List</a></small><br>\r
+ </td>\r
+ </tr>\r
+ <tr>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small>4<br>\r
+ </small></td>\r
+ <td valign="top" bgcolor="#ffffee"><small><a\r
+ href="mailto:3popmewpdl@freemail.com.au">3popmewpdl@freemail.com.au</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small>N/A<br>\r
+ </small></td>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small>N/A<br>\r
+ </small></td>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=white.list">White \r
+ list</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=black.list">Black \r
+ List</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=null.list">Null \r
+ List</a></small><br>\r
+ </td>\r
+ </tr>\r
+ <tr>\r
+ <td valign="top" align="center"><small>5<br>\r
+ </small></td>\r
+ <td valign="top"><small><a\r
+ href="mailto:4319jackie762r@excite.com">4319jackie762r@excite.com</a> \r
+ </small><br>\r
+ </td>\r
+ <td valign="top" align="center"><small>2<br>\r
+ </small></td>\r
+ <td valign="top" align="center"><small><a\r
+ href="http://defaria.com/maps/bin/display.cgi?email=-lee@yahoo.com;user=Andrew">Display</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=white.list">White \r
+ list</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=black.list">Black \r
+ List</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=null.list">Null \r
+ List</a></small><br>\r
+ </td>\r
+ </tr>\r
+ <tr>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small>6<br>\r
+ </small></td>\r
+ <td valign="top" bgcolor="#ffffee"><small><a\r
+ href="mailto:4yourliferate@businessvvorld.com">4yourliferate@businessvvorld.com</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small>4<br>\r
+ </small></td>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small><a\r
+ href="http://defaria.com/maps/bin/display.cgi?email=-lee@yahoo.com;user=Andrew">Display</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=white.list">White \r
+ list</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=black.list">Black \r
+ List</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=null.list">Null \r
+ List</a></small><br>\r
+ </td>\r
+ </tr>\r
+ <tr>\r
+ <td valign="top" align="center"><small>7<br>\r
+ </small></td>\r
+ <td valign="top"><small><a href="mailto:a10566@aol.com">a10566@aol.com</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center"><small>1<br>\r
+ </small></td>\r
+ <td valign="top" align="center"><small><a\r
+ href="http://defaria.com/maps/bin/display.cgi?email=-lee@yahoo.com;user=Andrew">Display</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=white.list">White \r
+ list</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=black.list">Black \r
+ List</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=null.list">Null \r
+ List</a></small><br>\r
+ </td>\r
+ </tr>\r
+ <tr>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small>8<br>\r
+ </small></td>\r
+ <td valign="top" bgcolor="#ffffee"><small><a\r
+ href="mailto:a14c17@aol.com">a14c17@aol.com</a> </small><br>\r
+ </td>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small>1<br>\r
+ </small></td>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small><a\r
+ href="http://defaria.com/maps/bin/display.cgi?email=-lee@yahoo.com;user=Andrew">Display</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=white.list">White \r
+ list</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=black.list">Black \r
+ List</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=null.list">Null \r
+ List</a></small><br>\r
+ </td>\r
+ </tr>\r
+ <tr>\r
+ <td valign="top" align="center"><small>9<br>\r
+ </small></td>\r
+ <td valign="top"><small><a\r
+ href="mailto:abaddon57@i-france.com">abaddon57@i-france.com</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center"><small>1<br>\r
+ </small></td>\r
+ <td valign="top" align="center"><small><a\r
+ href="http://defaria.com/maps/bin/display.cgi?email=-lee@yahoo.com;user=Andrew">Display</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=white.list">White \r
+ list</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=black.list">Black \r
+ List</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=null.list">Null \r
+ List</a></small><br>\r
+ </td>\r
+ </tr>\r
+ <tr>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small>10<br>\r
+ </small></td>\r
+ <td valign="top" bgcolor="#ffffee"><small><a\r
+ href="mailto:abaris@jippii.fi">abaris@jippii.fi</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small>3<br>\r
+ </small></td>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small><a\r
+ href="http://defaria.com/maps/bin/display.cgi?email=-lee@yahoo.com;user=Andrew">Display</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=white.list">White \r
+ list</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=black.list">Black \r
+ List</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=null.list">Null \r
+ List</a></small><br>\r
+ </td>\r
+ </tr>\r
+ <tr>\r
+ <td valign="top" align="center"><small>11<br>\r
+ </small></td>\r
+ <td valign="top"><small><a href="mailto:adsdssf_@zzn.com">adsdssf_@zzn.com</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center"><small>1<br>\r
+ </small></td>\r
+ <td valign="top" align="center"><small><a\r
+ href="http://defaria.com/maps/bin/display.cgi?email=-lee@yahoo.com;user=Andrew">Display</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=white.list">White \r
+ list</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=black.list">Black \r
+ List</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=null.list">Null \r
+ List</a></small><br>\r
+ </td>\r
+ </tr>\r
+ <tr>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small>12<br>\r
+ </small></td>\r
+ <td valign="top" bgcolor="#ffffee"><small><a\r
+ href="mailto:aduderstad3220@myself.com">aduderstad3220@myself.com</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small>N/A<br>\r
+ </small></td>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small>N/A<br>\r
+ </small></td>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=white.list">White \r
+ list</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=black.list">Black \r
+ List</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=null.list">Null \r
+ List</a></small><br>\r
+ </td>\r
+ </tr>\r
+ <tr>\r
+ <td valign="top" align="center"><small>13<br>\r
+ </small></td>\r
+ <td valign="top"><small><a\r
+ href="mailto:afk@crosswinds.net">afk@crosswinds.net</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center"><small>5<br>\r
+ </small></td>\r
+ <td valign="top" align="center"><small><a\r
+ href="http://defaria.com/maps/bin/display.cgi?email=-lee@yahoo.com;user=Andrew">Display</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=white.list">White \r
+ list</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=black.list">Black \r
+ List</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=null.list">Null \r
+ List</a></small><br>\r
+ </td>\r
+ </tr>\r
+ <tr>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small>14<br>\r
+ </small></td>\r
+ <td valign="top" bgcolor="#ffffee"><small><a\r
+ href="mailto:afrank@utopia.com">afrank@utopia.com</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small>1<br>\r
+ </small></td>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small><a\r
+ href="http://defaria.com/maps/bin/display.cgi?email=-lee@yahoo.com;user=Andrew">Display</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=white.list">White \r
+ list</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=black.list">Black \r
+ List</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=null.list">Null \r
+ List</a></small><br>\r
+ </td>\r
+ </tr>\r
+ <tr>\r
+ <td valign="top" align="center"><small>15<br>\r
+ </small></td>\r
+ <td valign="top"><small><a\r
+ href="mailto:aishazentz@london.com">aishazentz@london.com</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center"><small>1<br>\r
+ </small></td>\r
+ <td valign="top" align="center"><small><a\r
+ href="http://defaria.com/maps/bin/display.cgi?email=-lee@yahoo.com;user=Andrew">Display</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=white.list">White \r
+ list</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=black.list">Black \r
+ List</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=null.list">Null \r
+ List</a></small><br>\r
+ </td>\r
+ </tr>\r
+ <tr>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small>16<br>\r
+ </small></td>\r
+ <td valign="top" bgcolor="#ffffee"><small><a\r
+ href="mailto:aj@san.rr.com">aj@san.rr.com</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small>1<br>\r
+ </small></td>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small><a\r
+ href="http://defaria.com/maps/bin/display.cgi?email=-lee@yahoo.com;user=Andrew">Display</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=white.list">White \r
+ list</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=black.list">Black \r
+ List</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=null.list">Null \r
+ List</a></small><br>\r
+ </td>\r
+ </tr>\r
+ <tr>\r
+ <td valign="top" align="center"><small>17<br>\r
+ </small></td>\r
+ <td valign="top"><small><a href="mailto:akafu@excite.com">akafu@excite.com</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center"><small>1<br>\r
+ </small></td>\r
+ <td valign="top" align="center"><small><a\r
+ href="http://defaria.com/maps/bin/display.cgi?email=-lee@yahoo.com;user=Andrew">Display</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=white.list">White \r
+ list</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=black.list">Black \r
+ List</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=null.list">Null \r
+ List</a></small><br>\r
+ </td>\r
+ </tr>\r
+ <tr>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small>18<br>\r
+ </small></td>\r
+ <td valign="top" bgcolor="#ffffee"><small><a\r
+ href="mailto:al39@hotmail.com">al39@hotmail.com</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small>1<br>\r
+ </small></td>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small><a\r
+ href="http://defaria.com/maps/bin/display.cgi?email=-lee@yahoo.com;user=Andrew">Display</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=white.list">White \r
+ list</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=black.list">Black \r
+ List</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=null.list">Null \r
+ List</a></small><br>\r
+ </td>\r
+ </tr>\r
+ <tr>\r
+ <td valign="top" align="center"><small>19<br>\r
+ </small></td>\r
+ <td valign="top"><small><a\r
+ href="mailto:aldarupazmiy1@mail.com">aldarupazmiy1@mail.com</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center"><small>1<br>\r
+ </small></td>\r
+ <td valign="top" align="center"><small><a\r
+ href="http://defaria.com/maps/bin/display.cgi?email=-lee@yahoo.com;user=Andrew">Display</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=white.list">White \r
+ list</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=black.list">Black \r
+ List</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=null.list">Null \r
+ List</a></small><br>\r
+ </td>\r
+ </tr>\r
+ <tr>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small>20<br>\r
+ </small></td>\r
+ <td valign="top" bgcolor="#ffffee"><small><a\r
+ href="mailto:alesinettie@ief.hr">alesinettie@ief.hr</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small>1<br>\r
+ </small></td>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small><a\r
+ href="http://defaria.com/maps/bin/display.cgi?email=-lee@yahoo.com;user=Andrew">Display</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=white.list">White \r
+ list</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=black.list">Black \r
+ List</a></small><br>\r
+ </td>\r
+ <td valign="top" align="center" bgcolor="#ffffee"><small><a\r
+ href="http://defaria.com/maps/bin/add2list.cgi?email=-lee@yahoo.com;user=Andrew;list=null.list">Null \r
+ List</a></small><br>\r
+ </td>\r
+ </tr>\r
+ \r
+ </tbody> \r
+ </table>\r
+ </td>\r
+ </tr>\r
+ \r
+ </tbody> \r
+</table>\r
+ <br>\r
+ <br>\r
+ <br>\r
+ <br>\r
+</body>\r
+</html>\r
--- /dev/null
+<?php \r
+include "site-functions.php";\r
+include "MAPS.php"\r
+?>\r
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">\r
+<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US">\r
+<head>\r
+ <title>MAPS: Help</title>\r
+ <?php MAPSHeader ()?>\r
+</head>\r
+<body>\r
+\r
+<div class="heading">\r
+ <h2 class="header" align="center">\r
+ <font class="standout">MAPS</font> Spam Elimination System!</h2>\r
+</div>\r
+\r
+<div class="content">\r
+ <?php \r
+ OpenDB ();\r
+ SetContext ($userid);\r
+ NavigationBar ($userid);\r
+ ?>\r
+\r
+ <h3>What is MAPS?</h3>\r
+\r
+ <p>MAPS - which the observant might notice is SPAM spelt backwards -\r
+ works on a simple principal that is commonly used with Instant\r
+ Messenger (IM) clients such as AOL's Instant Messenger or\r
+ Microsoft's Messenger. That is that with most IM clients you need to\r
+ get the permission of the person you want to message before you can\r
+ send them an instant message. MAPS considers all email spam and\r
+ returns it to the sender unless the email is from somebody on your\r
+ white list.</p>\r
+\r
+ <p>Now white lists are not new but maintaining a white list is a\r
+ bother. So MAPS automates the maintaining of the that white list by\r
+ putting the responsibility of maintaining it on the people who wish\r
+ to email you. MAPS also seeks to make it easy for real people, not\r
+ spammers, to request permission to email you. Here's how it\r
+ works....</p>\r
+\r
+ <p>Email that is delivered to you is passed through a filter (maps\r
+ filter) which processes your email like so:</p>\r
+\r
+ <ol>\r
+\r
+ <li>Extract senders email address - no sender address (and no\r
+ envelope address)? Discard the email</li>\r
+\r
+ <li>Check to see if the sender is on your null list - if so\r
+ discard the email</li>\r
+\r
+ <li>Check to see if the sender is on your black list - if so\r
+ return a message telling the sender that s/he is blocked from\r
+ emailing you.</li>\r
+\r
+ <li>Check to see if the sender is on your white list - if so\r
+ deliver the mail</li>\r
+\r
+ <li>Otherwise send the sender a message with a link for them to\r
+ quickly register. Also, save their email so it can be delivered\r
+ when they register</li>\r
+\r
+ </ol>\r
+\r
+ <p>As you can see this algorithm will greatly reduce your\r
+ spam. Also, it's easy for real people to register. Spammers\r
+ typically do not read any email returning to them so they never\r
+ register!</p>\r
+\r
+ <h3>Other topics</h3>\r
+\r
+ <ul>\r
+\r
+ <li><a href="Requirements.php">Requirements</a></li>\r
+\r
+ <li><a href="/maps/SignupForm.html">Signup for MAPS</a></li>\r
+ \r
+ <li><a href="Using.php">Using MAPS</a></li>\r
+\r
+ </ul> \r
+\r
+ <?php copyright (2001);?>\r
+\r
+ </div>\r
+</body>\r
+</html>\r
--- /dev/null
+/************************************************************************/
+/* File: MAPSStyle.css */
+/* Description: Cascading Style Sheet definitions for MAPS */
+/* Author: Andrew@DeFaria.com */
+/* Created: Mon Nov 3 21:55:05 PST 2003 */
+/* Language: Cascading Style Sheet */
+/* */
+/* (c) Copyright 2003, Andrew@DeFaria.com, all rights reserved. */
+/************************************************************************/
+body {
+ background-color: #fff;
+ background-image: url(/maps/images/Pattern1.gif);
+ background-repeat: repeat-y;
+ color: #666;
+ font-family: trebuchet MS, trebuchet, verdana, arial, sans-serif;
+ font-size: 12px;
+ margin: 0px;
+}
+
+.heading {
+ margin-left: 140px;
+ margin-top: 5px;
+ padding: 5px;
+}
+
+.leftbar {
+ height: auto;
+ left: 2px;
+ position: absolute;
+ top: 5px;
+ width: 135px;
+}
+
+.username {
+ color: white;
+ font-family: veranda, arial;
+ font-style: bold;
+ font-size: 14px;
+ margin-left: 2px;
+ margin-bottom: 5px;
+ text-align: center;
+ width: 125px;
+}
+
+.menu {
+ background-color: #579;
+ background-image: url(/maps/images/worldnew.gif);
+ border: 2px groove black;
+ font-family: verdana, geneva, arial, helvetica, sans-serif;
+ font-size: 14px;
+ font-weight: bold;
+ line-height: 150%;
+ margin: 2px;
+ padding: 2px;
+ width: 122px;
+}
+
+.intromenu {
+ background-color: #579;
+ border: 2px groove black;
+ font-family: verdana, geneva, arial, helvetica, sans-serif;
+ font-size: 14px;
+ font-weight: bold;
+ line-height: 150%;
+ margin: 2px;
+ padding: 2px;
+ width: 125px;
+}
+
+.search {
+ background: #4682b4;
+ border: 2px groove black;
+ color: white;
+ font-family: veranda, arial;
+ font-style: bold;
+ margin-left: 2px;
+ margin-right: 5px;
+ text-align: center;
+ width: 125px;
+}
+
+.quickstats {
+ background-color: #ffffcc;
+ border: 2px groove #336699;
+ color: black;
+ font-size: 10px;
+ line-height: 10px;
+ margin: 2px;
+ padding: 2;
+ width: 125px;
+}
+
+.content {
+ background: #fff;
+ border: 0.1px solid #fff;
+ color: #666;
+ font-family: trebuchet MS, trebuchet, verdana, arial, sans-serif;
+ margin-left: 140px;
+ padding: 5px;
+ width: auto;
+}
+
+.copyright {
+ border-bottom: 1px dotted #ccc;
+ border-top: 1px dotted #ccc;
+ color: #666;
+ font-family: verdana, arial, sans-serif;
+ font-size: 10px;
+ margin-top: 5px;
+ text-align: center;
+ width: auto;
+}
+
+.label {
+ color: #993333;
+ font-weight: bold;
+ font-size: 14px;
+}
+
+.smalllabel {
+ color: #993333;
+ font-weight: bold;
+ font-size: 12px;
+}
+
+.smallnumber {
+ color: black;
+ font-size: 12px;
+}
+
+.header {
+ color: #000099;
+ font-weight: bold;
+}
+
+.standout {
+ color: red
+}
+
+.error {
+ color: red;
+ font-style: bold;
+}
+
+.dim {
+ color: #999999;
+}
+
+.dimsmall {
+ color: #999999;
+ font-size: 0.9em;
+ font-family: Times;
+}
+
+.highlite {
+ color: #000099;
+ font-weight: bold;
+}
+
+.inputfield {
+ background: #ece9d8;
+ color: Black;
+ font-family: Veranda,
+ Times;
+ font-size: 12px;
+ padding-top: 0px;
+ padding-bottom: 0px;
+}
+
+.note {
+ background: #339999;
+ color: White;
+ font-weight: bold;
+}
+
+.notetext {
+ color: #333;
+ font-size: 10px;
+ font-weight: italic;
+}
+
+# Headers
+h1, h2, h3, h4, h5 {
+ color: #000099;
+}
+
+h1 {
+ font-size: 18pt;
+}
+
+h2 {
+ font-size: 14pt;
+}
+
+h3 {
+ font-size: 10pt;
+}
+
+h4 {
+ font-size: 8pt;
+}
+
+# Global anchor effects
+a {
+ background: transparent;
+ text-decoration: none;
+}
+
+a:link {
+ color: #0000ee;
+}
+
+a:visited {
+ color: #cc33cc;
+}
+
+a:hover {
+ color: White;
+ background: #0054e3;
+}
+
+a:active {
+ color: #ff0000;
+}
+
+# Special anchor effects
+.sender {
+ font-weight: bold
+}
+
+.sender a:link {
+ color: Red;
+}
+
+.sender a:visited {
+ color: #0054e3;
+}
+
+.sender a:hover {
+ color: White;
+ background: Red;
+}
+
+.sender a:active {
+ color: Yellow;
+}
+
+# Menu anchors
+.menu {
+ font-weight: bold;
+}
+
+.menu a:link {
+ color: Red;
+}
+
+.menu a:visited {
+ color: white;
+}
+
+.menu a:hover {
+ color: White;
+ background: Red;
+}
+
+.menu a:active {
+ color: Yellow;
+}
+
+# Intromenu anchors
+.intromenu {
+ font-weight: bold;
+}
+
+.intromenu a:link {
+ color: Red;
+}
+
+.intromenu a:visited {
+ color: white;
+}
+
+.intromenu a:hover {
+ color: White;
+ background: Red;
+}
+
+.intromenu a:active {
+ color: Yellow;
+}
--- /dev/null
+################################################################################
+#
+# File: $RCSfile: mail.conf,v $
+# Revision: $Revision: 1.1 $
+# Description: Config file for Mail.pm
+# Author: Andrew@DeFaria.com
+# Created: Thu Aug 2 22:08:04 MST 2007
+# Modified: $Date: 2013/06/12 14:05:48 $
+# Language: conf
+#
+# (c) Copyright 2007, Andrew@DeFaria.com, all rights reserved
+#
+################################################################################
+SMTPHOST: defaria.com
+SMTPFROM: Andrew@DeFaria.com
\ No newline at end of file
--- /dev/null
+"|/usr/local/maps/bin/maps -u andrew"
--- /dev/null
+<?php \r
+include "site-functions.php";\r
+include "MAPS.php";\r
+\r
+$logout = $_REQUEST[logout];\r
+\r
+if (isset ($logout)) {\r
+ setcookie ("MAPSUser", "", time()+60*60*24*30, "/maps");\r
+} else {\r
+ if (isset ($userid) && $from_cookie) {\r
+ header ("Location: php/main.php");\r
+ exit;\r
+ } // if\r
+} // if\r
+?>\r
+\r
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">\r
+<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US">\r
+<head>\r
+ <title>MAPS: Mail Authorization and Permission System</title>\r
+ <?php MAPSHeader ()?>\r
+</head>\r
+<body>\r
+\r
+<div class="heading">\r
+ <h2 class="header" align="center">\r
+ <font class="standout">MAPS</font> Mail Authorization and Permission System</h2>\r
+ <h3 class="header" align="center">Spam Elimination System</h3>\r
+</div>\r
+\r
+<div class="content">\r
+ <?php\r
+ OpenDB ();\r
+ NavigationBar ("");\r
+ ?>\r
+\r
+ <p>MAPS is a system for totally eliminating spam from your life. It\r
+ seeks to minimize the amount of intervention and thus the amount of\r
+ time you spent dealing with unsolicited emails by requiring that all\r
+ email are solicited. MAPS provides a convenient way to manage your\r
+ spam and to allow those you wish to receive email from to be able to\r
+ email you without hassle.</p>\r
+\r
+ <p>To learn more about MAPS select an option from the menu on the\r
+ left. Be sure to read <a href="/maps/doc/Using.php">Using MAPS</a>\r
+ to familiarize yourself with how the MAPS system works and to\r
+ configure your email client. Then signup for an account (it's free!)\r
+ and login and enjoy spam free email!</p>\r
+\r
+ <form method="post" action="php/main.php"\r
+ enctype="application/x-www-form-urlencoded">\r
+ \r
+ <table cellpadding="2" bgcolor="white" width="40%" cellspacing="0" \r
+ border="0" align="center">\r
+\r
+ <tr>\r
+ <td class="label" valign="middle">Username:\r
+ </td>\r
+ <td valign="middle">\r
+ <input type="text" name="userid" size="20" class="inputfield"></input>\r
+ </td>\r
+ </tr>\r
+\r
+ <tr>\r
+ <td class="label" valign="middle">Password:\r
+ </td>\r
+ <td valign="middle">\r
+ <input type="password" name="password" size="20" class="inputfield"></input>\r
+ </td>\r
+ </tr>\r
+\r
+ <tr>\r
+ <td colspan="2" align="center"><input type="submit" name="submit" value="Login"></input>\r
+ </td>\r
+ </tr>\r
+\r
+ <?php\r
+ if (isset ($errormsg)) {\r
+ print "<tr><td class=error colspan=2 align=center>$errormsg</td></tr>";\r
+ } // if\r
+ ?>\r
+\r
+ <tr>\r
+ <td colspan="2" align="center">\r
+ <a href="php/ForgotPassword.php">Forgot your password?</a>\r
+ </td>\r
+ </tr>\r
+ </table>\r
+ </form>\r
+\r
+ <?php copyright (2001);?>\r
+\r
+ </div>\r
+</body>\r
+</html>\r
--- /dev/null
+################################################################################
+#
+# MAPS: Mail Authorization and Permission System (MAPS)
+# null.list: Default null.list file
+# Exported: Thu Jan 15 16:22:16 2004
+#
+# Copyright 2001-2004, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+mdaemon@,Mailer bounces
+postauto@,Mailer bounces
+postbot@aol.net,Mailer bounces
+postdaemon@,Mailer bounces
+postengine@,Mailer bounces
+postform@,Mailer bounces
+postmaster@,Mailer bounces
+postprogram@,Mailer bounces
+postrobot@,Mailer bounces
+postroutine@,Mailer bounces
+postservice@,Mailer bounces
+smtpautomat@,Mailer bounces
+smtpbot@,Mailer bounces
+smtpdaemon@,Mailer bounces
+smtpengine@,Mailer bounces
+smtpform@,Mailer bounces
+smtpprogram@,Mailer bounces
+smtprobot@,Mailer bounces
+smtproutine@,Mailer bounces
+smtpservice@,Mailer bounces
+specials@,Mailer bounces
+superdeal@,Mailer bounces
+superspecial@,Mailer bounces
+webautomat@,Mailer bounces
+webbot@,Mailer bounces
+webdaemon@,Mailer bounces
+webengine@,Mailer bounces
+webform@,Mailer bounces
+webjump@defaria.com,Webjump
+webrobot@,Mailer bounces
+webroutine@,Mailer bounces
+yahoo mail@,Mailer bounces
--- /dev/null
+<?php \r
+////////////////////////////////////////////////////////////////////////////////\r
+//\r
+// File: $RCSFile$\r
+// Revision: $Revision: 1.1 $\r
+// Description: Email's password to user who forgot\r
+// Author: Andrew@DeFaria.com\r
+// Created: Fri Nov 29 14:17:21 2002\r
+// Modified: $Date: 2013/06/12 14:05:48 $\r
+// Language: PHP\r
+//\r
+// (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.\r
+//\r
+////////////////////////////////////////////////////////////////////////////////\r
+include "site-functions.php";\r
+include "MAPS.php"\r
+?>\r
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">\r
+<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US">\r
+<head>\r
+ <title>MAPS: Forgot Password</title>\r
+ <?php MAPSHeader ()?>\r
+</head>\r
+<body>\r
+\r
+<div class="heading">\r
+ <h2 class="header" align="center">\r
+ <font class="standout">MAPS</font> Password Retrieval</h2>\r
+</div>\r
+\r
+<div class="content">\r
+ <?php\r
+ OpenDB ();\r
+ $userid = "";\r
+ NavigationBar ($userid);\r
+ ?>\r
+\r
+ <h3>Password Retrieval</h3>\r
+\r
+ <p>So you forgot your password! Hey it happens. Give us your\r
+ username and select <i>Send Me My Password</i> and we will email you\r
+ your password.</p>\r
+\r
+ <form method="post"\r
+ action="/maps/php/emailpassword.php?userid=$userid"\r
+ name="emailpassword">\r
+\r
+ <div align="center">\r
+\r
+ <input class="inputfield" type="text" name="userid" value="" size="20">\r
+\r
+ <p><input type="submit" value="Send Me My Password"></p>\r
+\r
+ </div>\r
+\r
+ </form>\r
+\r
+ <?php copyright (2001);?>\r
+\r
+ </div>\r
+</body>\r
+</html>\r
--- /dev/null
+<?php \r
+////////////////////////////////////////////////////////////////////////////////\r
+//\r
+// File: $RCSFile$\r
+// Revision: $Revision: 1.1 $\r
+// Description: Lists domains\r
+// Author: Andrew@DeFaria.com\r
+// Created: Fri Nov 29 14:17:21 2002\r
+// Modified: $Date: 2013/06/12 14:05:48 $\r
+// Language: PHP\r
+//\r
+// (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.\r
+//\r
+////////////////////////////////////////////////////////////////////////////////\r
+include "site-functions.php";\r
+include "MAPS.php";\r
+\r
+$top = $_REQUEST ["top"];\r
+\r
+if (!$top) {\r
+ $top = 20;\r
+} // if\r
+?>\r
+\r
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">\r
+<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US">\r
+<head>\r
+ <title>MAPS: Returned Messages by Domain</title>\r
+ <?php MAPSHeader ()?>\r
+ <script src="/maps/JavaScript/ListActions.js" type="text/javascript"></script>\r
+</head>\r
+<body>\r
+<div class="heading">\r
+<h2 class="header" align="center"><font class="standout">MAPS</font>\r
+Returned Messages by Domain</h2>\r
+</div>\r
+<div class="content">\r
+ <?php\r
+ OpenDB ();\r
+ SetContext ($userid);\r
+ NavigationBar ($userid);\r
+ ?>\r
+<form method="post" action="/maps/bin/processaction.cgi" enctype="application/x-www-form-urlencoded" name="domains">\r
+<?php ListDomains ($top);?>\r
+</form>\r
+<?php copyright (2001);?>\r
+</div>\r
+</body>\r
+</html>\r
--- /dev/null
+<?php
+////////////////////////////////////////////////////////////////////////////////
+//
+// File: $RCSFile$
+// Revision: $Revision: 1.1 $
+// Description: Main PHP module to MAPS
+// Author: Andrew@DeFaria.com
+// Created: Fri Nov 29 14:17:21 2002
+// Modified: $Date: 2013/06/12 14:05:48 $
+// Language: PHP
+//
+// (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
+//
+////////////////////////////////////////////////////////////////////////////////
+// Get userid
+if (isset ($_REQUEST ["userid"])) {
+ $userid = $_REQUEST ["userid"];
+} // if
+$from_cookie = false;
+
+if (!isset ($userid)) {
+ // No userid, see if we have a cookie for it
+ $userid=$_COOKIE["MAPSUser"];
+ $from_cookie = true;
+} // if
+
+$lines = 10;
+$Types = array (
+ "returned",
+ "whitelist",
+ "blacklist",
+ "registered",
+ "mailloop",
+ "nulllist"
+);
+
+function DBError ($msg, $statement) {
+ $errno = mysql_errno ();
+ $errmsg = mysql_error ();
+ print "$msg\nError # $errno $errmsg";
+ print "SQL Statement: $statement";
+
+ exit ($errno);
+} // DBError
+
+function OpenDB () {
+ $db = mysql_pconnect ("localhost", "mapsadmin", "mapsadmin")
+ or DBError ("OpenDB: Unable to connect to database server", "Connect");
+
+ mysql_select_db ("MAPS")
+ or DBError ("OpenDB: Unable to select MAPS database", "MAPS");
+} // OpenDB
+
+function SetContext ($new_userid) {
+ global $userid;
+
+ $userid = $new_userid;
+} // SetContext
+
+function Encrypt ($password, $userid) {
+ $statement = "select encode(\"$password\",\"$userid\")";
+
+ $result = mysql_query ($statement)
+ or DBError ("Encrypt: Unable to execute statement", $statement);
+
+ // Get return value, which should be the encoded password
+ $row = mysql_fetch_array ($result);
+
+ return $row [0];
+} // Encrypt
+
+function UserExists ($userid) {
+ $statement = "select userid, password from user where userid = \"$userid\"";
+
+ $result = mysql_query ($statement)
+ or DBError ("UserExists: Unable to execute statement", $statement);
+
+ $row = mysql_fetch_array ($result);
+
+ $dbuserid = $row ["userid"];
+ $dbpassword = $row ["password"];
+
+ if ($dbuserid != $userid) {
+ return -1;
+ } else {
+ return $dbpassword;
+ } # if
+} // UserExists
+
+function Login ($userid, $password) {
+ $password = Encrypt ($password, $userid);
+
+ // Check if user exists
+ $dbpassword = UserExists ($userid);
+
+ // Return -1 if user doesn't exist
+ if ($dbpassword == -1) {
+ return -1;
+ } // if
+
+ // Return -2 if password does not match
+ if ($password != $dbpassword) {
+ return -2;
+ } else {
+ setcookie ("MAPSUser", $userid, time()+60*60*24*30, "/maps");
+ SetContext ($userid);
+ return 0;
+ } // if
+} // Login
+
+function CountList ($type) {
+ global $userid;
+
+ $statement = "select count(*) as count from list where type=\"$type\" and userid=\"$userid\"";
+
+ $result = mysql_query ($statement)
+ or DBError ("CountList: Unable to count list: ", $statement);
+
+ // How many rows are there?
+ $row = mysql_fetch_array ($result);
+
+ return $row ["count"];
+} // CountList
+
+function FindList ($type, $next, $lines) {
+ global $db;
+ global $userid;
+ global $lines;
+
+ $statement = "select * from list where type=\"$type\" and userid=\"$userid\" order by sequence limit $next, $lines";
+
+ $result = mysql_query ($statement)
+ or DBError ("FindList: Unable to execute query: ", $statement);
+
+ $count = mysql_num_rows ($result);
+
+ return array ($count, $result);
+} // FindList
+
+function Today2SQLDatetime () {
+ return date ("Y-m-d H:i:s");
+} // Today2SQLDatetime
+
+function countem ($table, $condition) {
+ $statement = "select count(distinct sender) as count from $table where $condition";
+
+ $result = mysql_query ($statement)
+ or DBError ("countem: Unable to perform query: ", $statement);
+
+ // How many rows are there?
+ $row = mysql_fetch_array ($result);
+
+ return $row ["count"];
+} // countem
+
+function countlog ($condition="") {
+ global $userid;
+
+ if ($condition != "") {
+ return countem ("log", "userid=\"$userid\" and " . $condition);
+ } else {
+ return countem ("log", "userid=\"$userid\"");
+ } // if
+} // countlog
+
+function SubtractDays ($date, $nbr_days) {
+
+} // SubtractDays
+
+function GetStats ($nbr_days, $date = "") {
+ global $Types;
+
+ if ($date == "") {
+ $date = Today2SQLDatetime ();
+ } // if
+
+ while ($nbr_days > 0) {
+ $ymd = substr ($date, 0, 10);
+ $sod = $ymd . " 00:00:00";
+ $eod = $ymd . " 23:59:59";
+
+ foreach ($Types as $type) {
+ $condition = "type=\"$type\" and (timestamp > \"$sod\" and timestamp < \"$eod\")";
+ $stats[$type] = countlog ($condition);
+ } # foreach
+
+ $dates[$ymd] = &$stats;
+
+ $date = SubtractDays ($date, 1);
+ $nbr_days--;
+ } # while
+
+ return $dates;
+} # GetStats
+
+function displayquickstats () {
+ $today = substr (Today2SQLDatetime (), 0, 10);
+ $dates = getquickstats ($today);
+ $current_time = date ("g:i a");
+
+ // Start quickstats
+ print "<div class=quickstats>";
+ print "<h4 align=center class=header>Today's Activity</h4>";
+ print "<p align=center><b>as of $current_time</b></p>";
+
+ $processed = $dates[$today]["processed"];
+ $returned = $dates[$today]["returned"];
+ $returned_pct = $processed == 0 ? 0 :
+ number_format ($returned / $processed * 100, 1, ".", "");
+ $whitelist = $dates[$today]["whitelist"];
+ $whitelist_pct = $processed == 0 ? 0 :
+ number_format ($whitelist / $processed * 100, 1, ".", "");
+ $blacklist = $dates[$today]["blacklist"];
+ $blacklist_pct = $processed == 0 ? 0 :
+ number_format ($blacklist / $processed * 100, 1, ".", "");
+ $registered = $dates[$today]["registered"];
+ $mailloop = $dates[$today]["mailloop"];
+ $nulllist = $dates[$today]["nulllist"];
+ $nulllist_pct = $processed == 0 ? 0 :
+ number_format ($nulllist / $processed * 100, 1, ".", "");
+
+ $returned_link = $returned == 0 ? 0 :
+ "<a href=/maps/bin/detail.cgi?type=returned;date=$today>$returned</a>";
+ $whitelist_link = $whitelist == 0 ? 0 :
+ "<a href=/maps/bin/detail.cgi?type=whitelist;date=$today>$whitelist</a>";
+ $blacklist_link = $blacklist == 0 ? 0 :
+ "<a href=/maps/bin/detail.cgi?type=blacklist;date=$today>$blacklist</a>";
+ $registered_link = $registered == 0 ? 0 :
+ "<a href=/maps/bin/detail.cgi?type=registered;date=$today>$registered</a>";
+ $mailloop_link = $mailloop == 0 ? 0 :
+ "<a href=/maps/bin/detail.cgi?type=mailloop;date=$today>$mailloop</a>";
+ $nulllist_link = $nulllist == 0 ? 0 :
+ "<a href=/maps/bin/detail.cgi?type=nulllist;date=$today>$nulllist</a>";
+
+print <<<EOT
+<table cellpadding="2" border="0" align="center" cellspacing="0">
+ <tr align="right">
+ <td align="right" class="smalllabel">Processed</td>
+ <td align="right" class="smallnumber">$processed</td>
+ <td align="right" class="smallnumber">n/a</td>
+ </tr>
+ <tr align="right">
+ <td class="smalllabel">Returned</td>
+ <td class=smallnumber>$returned_link
+ <td class="smallnumber">$returned_pct%</td>
+ </tr>
+ <tr align="right">
+ <td class="smalllabel">Whitelist</td>
+ <td class="smallnumber">$whitelist_link
+ <td class="smallnumber">$whitelist_pct%</td>
+ </tr>
+ <tr align="right">
+ <td class="smalllabel">Blacklist</td>
+ <td class="smallnumber">$blacklist_link
+ <td class="smallnumber">$blacklist_pct%</td>
+ </tr>
+ <tr align="right">
+ <td class="smalllabel">Registered</td>
+ <td class="smallnumber">$registered_link
+ <td class="smallnumber">n/a</td>
+ </tr>
+ <tr align="right">
+ <td class="smalllabel">Mailloop</td>
+ <td class="smallnumber">$mailloop_link
+ <td class="smallnumber">n/a</td>
+ </tr>
+ <tr align="right">
+ <td class="smalllabel">Nulllist</td>
+ <td class="smallnumber">$nulllist_link
+ <td class="smallnumber">$nulllist_pct%</td>
+ </tr>
+</table>
+</div>
+EOT;
+} // displayquickstats
+
+function getquickstats ($date) {
+ global $Types;
+
+ $dates = GetStats (1, $date);
+
+ foreach ($Types as $type) {
+ if (isset ($dates [$date]["processed"])) {
+ $dates [$date]["processed"] += $dates [$date][$type];
+ } else {
+ $dates [$date]["processed"] = $dates [$date][$type];
+ } // if
+ } # foreach
+
+ return $dates;
+} // getquickstats
+
+function NavigationBar ($userid) {
+ print "<div id=leftbar>";
+
+ if (!isset ($userid) || $userid == "") {
+ print <<<END
+ <div class="username">Welcome to MAPS</div>
+ <div class="menu">
+ <a href="/maps/doc/">What is MAPS?</a><br>
+ <a href="/maps/doc/SPAM.php">What is SPAM?</a><br>
+ <a href="/maps/doc/Requirements.php">Requirements</a><br>
+ <a href="/maps/SignupForm.html">Signup</a><br>
+ <a href="/maps/doc/Using.php">Using MAPS</a><br>
+ <a href="/maps/doc/">Help</a><br>
+ </div>
+END;
+ } else {
+ $Userid = ucfirst ($userid);
+ print <<<END
+ <div class="username">Welcome $Userid</div>
+ <div class="menu">
+ <a href="/maps/">MAPS Home</a><br>
+ <a href="/maps/bin/stats.cgi">Statistics</a><br>
+ <a href="/maps/bin/editprofile.cgi">Edit Profile</a><br>
+ <a href="/maps/php/Reports.php">Reports</a><br>
+ <a href="/maps/php/list.php?type=white">White List</a><br>
+ <a href="/maps/php/list.php?type=black">Black List</a><br>
+ <a href="/maps/php/list.php?type=null">Null List</a><br>
+ <a href="/maps/doc/">Help</a><br>
+ <a href="/maps/adm/">MAPS Admin</a><br>
+ <a href="/maps/?logout=yes">Logout</a>
+ </div>
+END;
+ print <<<END
+ <div class="search">
+ <form method="get" action="/maps/bin/search.cgi" name="search">
+ Search Sender/Subject
+ <input type="text" class="searchfield" id="searchfield" name="str"
+ size="20" maxlength="255" value="" onclick="document.search.str.value='';">
+ </form>
+ </div>
+END;
+
+ displayquickstats ();
+
+ print <<<END
+ <div class="search">
+ <form "method"=post action="javascript://" name="address"
+ onsubmit="checkaddress(this);">
+ Check Email Address
+ <input type="text" class="searchfield" id="searchfield" name="email"
+ size="20" maxlength="255" value="" onclick="document.address.email.value = '';">
+ </form>
+ </div>
+END;
+ } // if
+
+ print "</div>";
+} # NavigationBar
+
+function GetUserLines () {
+ global $userid;
+
+ $lines = 10;
+
+ $statement = "select value from useropts where userid=\"$userid\" and name=\"Page\"";
+
+ $result = mysql_query ($statement)
+ or DBError ("GetUserLines: Unable to execute query: ", $statement);
+
+ $row = mysql_fetch_array ($result);
+
+ if (isset ($row["value"])) {
+ $lines = $row["value"];
+ } // if
+
+ return $lines;
+} // GetUserLines
+
+function DisplayList ($type, $next, $lines) {
+ global $userid;
+ global $total;
+ global $last;
+
+ $statement="select * from list where userid=\"$userid\" and type=\"$type\" order by sequence limit $next, $lines";
+
+ $result = mysql_query ($statement)
+ or DBError ("DisplayList: Unable to execute query: ", $statement);
+
+ for ($i = 0; $i < $lines; $i++) {
+ $row = mysql_fetch_array ($result);
+
+ if (!isset ($row ["sequence"])) {
+ break;
+ } // if
+
+ $sequence = $row ["sequence"];
+ $username = $row ["pattern"] == "" ? " " : $row ["pattern"];
+ $domain = $row ["domain"] == "" ? " " : $row ["domain"];
+ $hit_count = $row ["hit_count"] == "" ? " " : $row ["hit_count"];
+ $last_hit = $row ["last_hit"] == "" ? " " : $row ["last_hit"];
+ $comments = $row ["comment"] == "" ? " " : $row ["comment"];
+
+ // Remove time from last hit
+ $last_hit = substr ($last_hit, 0, (strlen ($last_hit) - strpos ($last_hit, " ")) + 1);
+
+ // Reformat last_hit
+ $last_hit = substr ($last_hit, 5, 2) . "/" .
+ substr ($last_hit, 8, 2) . "/" .
+ substr ($last_hit, 0, 4);
+ $leftclass = ($i == $lines || $sequence == $total || $sequence == $last) ?
+ "tablebottomleft" : "tableleftdata";
+ $dataclass = ($i == $lines || $sequence == $total || $sequence == $last) ?
+ "tablebottomdata" : "tabledata";
+ $rightclass = ($i == $lines || $sequence == $total || $sequence == $last) ?
+ "tablebottomright" : "tablerightdata";
+
+ print "<td class=$leftclass align=center>" . $sequence . "</td>";
+ print "<td class=$dataclass align=center><input type=checkbox name=action" . $sequence . " value=on></td>\n";
+ print "<td class=$dataclass align=right>" . $username . "</td>";
+ print "<td class=$dataclass align=center>@</td>";
+ print "<td class=$dataclass align=left>" . $domain . "</td>";
+ print "<td class=$dataclass align=right>" . $hit_count . "</td>";
+ print "<td class=$dataclass align=center>" . $last_hit . "</td>";
+ print "<td class=$rightclass align=left>" . $comments . "</td>";
+ print "</tr>";
+ } // for
+} // DisplayList
+
+function MAPSHeader () {
+ print <<<END
+ <meta name="author" content="Andrew DeFaria <Andre@DeFaria.com>">
+ <meta name="MAPS" "Mail Authorization and Permission System">
+ <meta name="keywords" content="Eliminate SPAM, Permission based email, SPAM filtering system">
+ <meta http-equiv=Refresh content="900">
+ <link rel="icon" href="/maps/MAPS.png" type="image/png">
+ <link rel="SHORTCUT ICON" href="/maps/favicon.ico">
+ <link rel="stylesheet" type="text/css" href="/maps/css/MAPSStyle.css"/>
+ <script language="JavaScript1.2" src="/maps/JavaScript/MAPSUtils.js"
+ type="text/javascript"></script>
+ <script language="JavaScript1.2" src="/maps/JavaScript/CheckAddress.js"
+ type="text/javascript"></script>
+END;
+} // MAPSHeader
+
+function ListDomains ($top = 10) {
+ global $userid;
+
+ // Generate a list of the top 10 spammers by domain
+ $statement = "select count(sender) as nbr, ";
+ // Must extract domain from sender...
+ $statement = $statement . "substring(sender, locate(\"@\",sender, 1)+1) as domain ";
+ // From email for the current userid...
+ $statement = $statement . "from email where userid=\"$userid\" ";
+ // Group things by domain but order them descending on nbr...
+ $statement = $statement . "group by domain order by nbr desc";
+
+ // Do the query
+ $result = mysql_query ($statement)
+ or DBError ("ListDomains: Unable to execute query: ", $statement);
+
+ print <<<END
+ <table border="0" cellspacing="0" cellpadding="4" align="center" name="domainlist">
+ <tr>
+ <th class="tableleftend">Mark</th>
+ <th class="tableheader">Ranking</th>
+ <th class="tableheader">Domain</th>
+ <th class="tablerightend">Returns</th>
+ </tr>
+END;
+
+ // Get results
+ for ($i = 0; $i < $top; $i++) {
+ $row = mysql_fetch_array ($result);
+ $domain = $row["domain"];
+ $nbr = $row["nbr"];
+
+ print "<tr>";
+ $ranking = $i + 1;
+ if ($i < $top - 1) {
+ print "<td class=tableleftdata align=center><input type=checkbox name=action" . $i . " value=on></td>\n";
+ print "<td align=center class=tabledata>" . $ranking . "</td>";
+ print "<td class=tabledata>$domain</td>";
+ print "<input type=hidden name=email$i value=\"@$domain\">";
+ print "<td align=center class=tablerightdata>$nbr</td>";
+ } else {
+ print "<td class=tablebottomleft align=center><input type=checkbox name=action" . $i . " value=on></td>\n";
+ print "<td align=center class=tablebottomdata>" . $ranking . "</td>";
+ print "<td class=tablebottomdata>$domain</td>";
+ print "<input type=hidden name=email$i value=\"@$domain\">";
+ print "<td align=center class=tablebottomright>$nbr</td>";
+ } // if
+ print "</tr>";
+ } // for
+
+ print <<<END
+ <tr>
+ <td align=center colspan=4><input type="submit" name="action" value="Nulllist Marked" onclick="return CheckAtLeast1Checked (document.domains);" /><input type="submit" name="action" value="Reset Marks" onclick="return ClearAll (document.domains);" />
+ </td>
+ </tr>
+<table>
+END;
+} // ListDomains
+
+function Space () {
+ global $userid;
+
+ // Tally up space used by $userid
+ $space = 0;
+
+ $statement = "select * from email where userid = \"$userid\"";
+
+ $result = mysql_query ($statement)
+ or DBError ("Space: Unable to execute query: ", $statement);
+
+ while ($row = mysql_fetch_array ($result)) {
+ $msg_space =
+ strlen ($row["userid"]) +
+ strlen ($row["sender"]) +
+ strlen ($row["subject"]) +
+ strlen ($row["timestamp"]) +
+ strlen ($row["data"]);
+ $space = $space + $msg_space;
+ } // while
+
+ return $space;
+} // Space
+?>
--- /dev/null
+<?php \r
+////////////////////////////////////////////////////////////////////////////////\r
+//\r
+// File: $RCSFile$\r
+// Revision: $Revision: 1.1 $\r
+// Description: MAPS Reports\r
+// Author: Andrew@DeFaria.com\r
+// Created: Fri Nov 29 14:17:21 2002\r
+// Modified: $Date: 2013/06/12 14:05:48 $\r
+// Language: PHP\r
+//\r
+// (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.\r
+//\r
+////////////////////////////////////////////////////////////////////////////////\r
+include "site-functions.php";\r
+include "MAPS.php";\r
+?>\r
+\r
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">\r
+<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US">\r
+<head>\r
+ <title>MAPS: Reports</title>\r
+ <?php MAPSHeader ()?>\r
+</head>\r
+<body>\r
+<div class="heading">\r
+<h2 class="header" align="center"><font class="standout">MAPS</font>\r
+Reports</h2>\r
+</div>\r
+<div class="content">\r
+ <?php\r
+ OpenDB ();\r
+ SetContext ($userid);\r
+ NavigationBar ($userid);\r
+ ?>\r
+\r
+ <h2>Reports</h2>\r
+ <ul>\r
+ <li><a href="/maps/php/ListDomains.php">Returned messages by domain</a></li>\r
+ <li>Recent Activity</li>\r
+ <li><a href="/maps/php/Space.php">Space Usage</a> (this report may take a while)</li>\r
+ </ul>\r
+\r
+ <?php copyright (2001);?>\r
+</div>\r
+</body>\r
+</html>\r
--- /dev/null
+<?php \r
+////////////////////////////////////////////////////////////////////////////////\r
+//\r
+// File: $RCSFile$\r
+// Revision: $Revision: 1.1 $\r
+// Description: Reports user's database space usage\r
+// Author: Andrew@DeFaria.com\r
+// Created: Fri Nov 29 14:17:21 2002\r
+// Modified: $Date: 2013/06/12 14:05:48 $\r
+// Language: PHP\r
+//\r
+// (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.\r
+//\r
+////////////////////////////////////////////////////////////////////////////////\r
+include "site-functions.php";\r
+include "MAPS.php";\r
+?>\r
+\r
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">\r
+<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US">\r
+<head>\r
+ <title>MAPS: Space Usage</title>\r
+ <?php \r
+ MAPSHeader ();\r
+ $Userid = ucfirst ($userid);\r
+ ?>\r
+</head>\r
+<body>\r
+<div class="heading">\r
+<h2 class="header" align="center"><font class="standout">MAPS</font>\r
+Space Usage for <?php echo $Userid?></h2>\r
+</div>\r
+<div class="content">\r
+ <?php\r
+ OpenDB ();\r
+ SetContext ($userid);\r
+ NavigationBar ($userid);\r
+ $space = Space ();\r
+ $one_meg = 1024 * 1024;\r
+\r
+ if ($space > $one_meg) {\r
+ $space = number_format ($space / $one_meg, 1);\r
+ print "$Userid is using up $space Megabytes of space in the database";\r
+ } elseif ($space > 0) {\r
+ $space = number_format ($space / 1024, 0);\r
+ print "$Userid is using up $space Kbytes of space in the database";\r
+ } else {\r
+ print "$Userid is using up no space in the database";\r
+ } // if\r
+\r
+ copyright (2001);\r
+ ?>\r
+</div>\r
+</body>\r
+</html>\r
--- /dev/null
+<?php
+////////////////////////////////////////////////////////////////////////////////
+//
+// File: $RCSFile$
+// Revision: $Revision: 1.1 $
+// Description: Email's password to user who forgot
+// Author: Andrew@DeFaria.com
+// Created: Fri Nov 29 14:17:21 2002
+// Modified: $Date: 2013/06/12 14:05:48 $
+// Language: PHP
+//
+// (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
+//
+////////////////////////////////////////////////////////////////////////////////
+include "site-functions.php";
+include "MAPS.php";
+
+$next = (isset ($_GET [next])) ? $_GET[next] : 0;
+$userid = $_REQUEST [userid];
+
+// Connect to DB
+OpenDB ();
+SetContext ($userid);
+
+// Get user information
+$statement = "select * from user where userid=\"$userid\"";
+
+$result = mysql_query ($statement)
+ or die ("emailpassword: SQL Query failed: " . $statement);
+
+$row = mysql_fetch_array ($result);
+
+$name = $row [name];
+$email = $row [email];
+$password = $row [password];
+$subject = "Your MAPS Password";
+
+// Decode password
+$statement = "select decode(\"$password\",\"$userid\")";
+
+$result = mysql_query ($statement);
+
+$row = mysql_fetch_array ($result, MYSQL_NUM);
+
+$decoded_password = $row [0];
+
+// Compose email
+$message = "
+<html>
+<head>
+ <title>Your MAPS Password</title>
+</head>
+<body>
+<p>Your MAPS Password is $decoded_password</p>
+
+<p>Click <a href=http://defaria.com/maps>here</a> to login to MAPS.
+</body>
+</html>
+";
+
+/* To send HTML mail, you can set the Content-type header. */
+$headers = "MIME-Version: 1.0\r\n";
+$headers .= "Content-type: text/html; charset=iso-8859-1\r\n";
+
+/* additional headers */
+$headers .= "To: $email\r\n";
+$headers .= "From: MAPS <MAPS@defaria.com>\r\n";
+
+/* and now mail it */
+$mailed = mail($to, $subject, $message, $headers);
+?>
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US">
+<head>
+ <title>MAPS: Password Retrieval</title>
+ <?php MAPSHeader ()?>
+</head>
+<body>
+
+<div class="heading">
+ <h2 class="header" align="center">
+ <font class="standout">MAPS</font> Password Retrieval</h2>
+</div>
+
+<div class="content">
+ <?php NavigationBar ("")?>
+
+ <p>Your password has been emailed to <?php echo $email?></p>
+
+ <?php copyright (2001)?>
+
+</body>
+</html>
--- /dev/null
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
+<?php
+////////////////////////////////////////////////////////////////////////////////
+//
+// File: $RCSFile$
+// Revision: $Revision: 1.1 $
+// Description: Process lists
+// Author: Andrew@DeFaria.com
+// Created: Fri Nov 29 14:17:21 2002
+// Modified: $Date: 2013/06/12 14:05:48 $
+// Language: PHP
+//
+// (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
+//
+////////////////////////////////////////////////////////////////////////////////
+ include "site-functions.php";
+ include "MAPS.php";
+ MAPSHeader ();
+ $next = (isset ($_GET ["next"])) ? $_GET ["next"] : 0;
+// $prev;
+ $type = $_GET ["type"];
+ $message = $_GET ["message"];
+ $Type = ucfirst ($type);
+ $Userid = ucfirst ($userid);
+?>
+<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US">
+<head>
+ <title>MAPS: Manage <?php echo "$Type"?> List</title>
+ <script language="JavaScript1.2" src="/maps/JavaScript/ListActions.js"
+ type="text/javascript"></script>
+<?php
+// Connect to MySQL
+OpenDB ();
+
+// Set User context
+SetContext ($userid);
+
+// Set $lines
+$lines = GetUserLines ();
+
+if (($next - $lines) > 0) {
+ $prev = $next - $lines;
+} else {
+ $prev = $next == 0 ? -1 : 0;
+} // if
+
+$total = CountList ($type);
+$last = $next + $lines < $total ? $next + $lines : $total;
+$last_page = floor ($total / $lines);
+$this_page = $next / $lines + 1;
+?>
+</head>
+<body>
+
+<div class="heading">
+ <h2 class="header" align="center">
+ <font class="standout">MAPS</font> Manage <?php echo "$Userid's "; echo $Type?> List</h2>
+</div>
+
+<div class="content">
+ <?php NavigationBar ($userid)?>
+ <form method="post" action="/maps/bin/processaction.cgi" name="list">
+ <div align="center">
+ <?php
+ if ($message != "") {
+ print "<center><font class=\"error\">$message</font></center>";
+ } // if
+ $current = $next + 1;
+ print "<input type=hidden name=type value=$type>";
+ print "<input type=hidden name=next value=$next>";
+ print "Page: <select name=page onChange=\"ChangePage(this.value,'$type','$lines');\"";
+ for ($i = 1; $i <= $last_page; $i++) {
+ if ($i == ($this_page - 1)) {
+ print "<option selected>$i</option>";
+ } else {
+ print "<option>$i</option>";
+ } // if
+ } // for
+ print "</select>";
+ print " of $last_page";
+ ?>
+ </div>
+ <div class="toolbar" align="center">
+ <?php
+ $prev_button = $prev >= 0 ?
+ "<a href=list.php?type=$type&next=$prev><img src=/maps/images/previous.gif border=0 alt=Previous align=middle></a>" : "";
+ $next_button = ($next + $lines) < $total ?
+ "<a href=list.php?type=$type&next=" . ($next + $lines) . "><img src=/maps/images/next.gif border=0 alt=Previous align=middle></a>" : "";
+ print $prev_button;
+ ?>
+ <input type="submit" name="action" value="Add New Entry"
+ onclick="return NoneChecked (document.list);">
+ <input type="submit" name="action" value="Delete Marked"
+ onclick="return CheckAtLeast1Checked (document.list) && AreYouSure ('Are you sure you want to delete these entries?');">
+ <input type="submit" name="action" value="Modify Marked"
+ onclick="return CheckAtLeast1Checked (document.list);">
+ <input type="submit" name="action" value="Reset Marks"
+ onclick="return ClearAll (document.list);">
+ <?php print $next_button?>
+ </div>
+ <table border="0" cellspacing="0" cellpadding="4" width="100%" align="center" name="list">
+ <tr>
+ <th class="tableleftend">Seq</th>
+ <th class="tableheader">Mark</th>
+ <th class="tableheader">Username</th>
+ <th class="tableheader">@</th>
+ <th class="tableheader">Domain</th>
+ <th class="tableheader">Hit Count</th>
+ <th class="tableheader">Last Hit</th>
+ <th class="tablerightend">Comments</th>
+ </tr>
+
+ <?php DisplayList ($type, $next, $lines)?>
+
+ </table>
+ <br>
+ <div align=center>
+ <a href="/maps/bin/exportlist.cgi?type=<?php echo $type?>">
+ <input type=submit name=export value="Export list"></a>
+ <a href="/maps/bin/importlist.cgi?type=<?php echo $type?>">
+ <input type=submit name=import value="Import List"></a>
+ </div>
+ </form>
+ <?php copyright (2001)?>
+
+</body>
+</html>
--- /dev/null
+<?php
+////////////////////////////////////////////////////////////////////////////////
+//
+// File: $RCSFile$
+// Revision: $Revision: 1.1 $
+// Description: Display MAPS main page
+// Author: Andrew@DeFaria.com
+// Created: Fri Nov 29 14:17:21 2002
+// Modified: $Date: 2013/06/12 14:05:48 $
+// Language: PHP
+//
+// (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
+//
+////////////////////////////////////////////////////////////////////////////////
+include "site-functions.php";
+include "MAPS.php";
+
+OpenDB ();
+
+$password = $_REQUEST ["password"];
+
+if (isset ($userid)) {
+ if (!$from_cookie) {
+ $result = Login ($userid, $password);
+
+ if ($result == -1) {
+ header ("Location: /maps/?errormsg=User $userid does not exist");
+ exit ($result);
+ } elseif ($result == -2) {
+ header ("Location: /maps/?errormsg=Invalid password");
+ exit ($result);
+ } // if
+ } // if
+} else {
+ header ("Location: /maps/?errormsg=Please specify a username");
+ exit ($result);
+} // if
+?>
+
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US">
+<head>
+ <title>MAPS: Home</title>
+ <?php MAPSHeader ()?>
+</head>
+<body>
+
+<div class="heading">
+ <h2 class="header" align="center">
+ <font class="standout">MAPS</font> Spam Elimination</h2>
+</div>
+
+<div class="content">
+ <?php NavigationBar ($userid)?>
+
+ <h3>Welcome to MAPS!</h3>
+
+ <p>This is the main or home page of MAPS. To the left you see a menu
+ of choices that you can use to explore MAPS functionality. <a
+ href="/maps/bin/stats.cgi">Statistics</a> gives you a view of the
+ spam that MAPS has been trapping for you in tabular format. You can
+ use <a href="/maps/bin/editprofile.cgi">Edit Profile</a> to change
+ your profile information or to change your password.</p>
+
+ <p>MAPS also offers a series of web based <a
+ href="/maps/php/Reports.php">Reports</a> to analyze your mail flow. You
+ can manage your <a href="/maps/php/list.php?type=white">White</a>,
+ <a href="/maps/php/list.php?type=black">Black</a> and <a
+ href="/maps/php/list.php?type=null">Null</a> lists although MAPS
+ seeks to put that responsibility on those who wish to email you. You
+ can use this to pre-register somebody or to black or null list
+ somebody. You can also import/export your lists through these
+ pages.</p>
+
+ <p><a href="/maps/Admin.html">MAPS Administration</a> is to
+ administer MAPS itself and is only available to MAPS
+ Administrators.</p>
+
+ <p>Also on the left you will see <i>Today's Activity</i> which
+ quickly shows you what mail MAPS processed today for you.</p>
+
+ <?php copyright (2001);?>
+
+ </div>
+</body>
+</html>
--- /dev/null
+<!doctype html public "-//w3c//dtd html 4.01 transitional//en">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html;charset=ISO-8859-1">
+ <link rel="stylesheet" type="text/css" href="http://defaria.com/maps/css/MAPSPlain.css">
+ <title>MAPS Registration</title>
+</head>
+
+<body>
+
+<h1 align="center"><font color="#ff0000">Mail Authorization and
+Permission System</font></h1>
+
+<div class=rightbox>
+
+<font color="#007777" size=+1></b>To register and send your previous
+email click <a
+href="http://defaria.com/maps/bin/registerform.cgi?userid=$userid;sender=$sender">here</a></b></font>
+
+<p>For your convience you email message is attached to this
+message. Note that if you register your previous emails will be
+delivered therefore you do not need to resend the message that is
+attached to this one.
+</div>
+
+<p>My email address is protected by <a
+href="http://defaria.com/maps/">Mail Authorization and Permission
+System (MAPS)</a>. You must register to email me. Registration is
+quick and easy and you need only register once to be added to my
+<i>white list</i>, thereafter you should have no problems emailing
+me. This is not unlike the authorization procedure in many instant
+messaging clients.</p>
+
+<p>This registration process is instantaneous however I reserve the
+right to remove you from my <i>white list</i> should you abuse this
+privilege.</p>
+
+<div class="notetext">
+
+<p><font class="standout"><b>Special note to solicitors:</b></font>
+Please remove my email address from any and all lists that you
+maintain or sell. I do not wish to receive any solicitations via
+email. I do not give you permission to sell or otherwise use my email
+address for any purpose whatsoever. I reserve the right to add you to
+my <i>white list</i> as well as to put you on my <i>black list</i>. If
+I do wish to receive email from you <b>I</b> will add you to my list
+myself. If you register for permission to email me then I will most
+likely move you to my <i>black list</i>.</p>
+
+</div>
+
+<div class="copyright">
+
+Copyright © 2001-2005 - All rights reserved<br>
+
+<a href="http://defaria.com/">Andrew DeFaria</a> <a
+href="mailto:Andrew@DeFaria.com"><Andrew@DeFaria.com></a>
+
+</div>
+</form>
+</body>
+</html>
--- /dev/null
+! Rxvt defaults
+
+! Global
+Rxvt*font: "Lucida Console-*-16"
+Rxvt*font1: "Lucida Console-*-18"
+Rxvt*font2: "Lucida Console-*-20"
+Rxvt*font3:
+Rxvt*font4:
+Rxvt*saveLines: 5000
+Rxvt*termName: cygwin
+Rxvt*scrollBar_right: True
+Rxvt*geometry: 80x24
+Rxvt*loginShell: True
+
+! Default
+Rxvt.background: Black
+Rxvt.foreground: White
+Rxvt.colorBD: Blue
+Rxvt.colorUL: Red
+Rxvt.cursorColor: Yellow
+XTerm.background: SteelBlue
+XTerm.foreground: White
+XTerm.colorBD: Blue
+XTerm.colorUL: Red
+XTerm.cursorColor: Yellow
+
+! New server
+Jupiter.background: MidNightBlue
+Jupiter.foreground: White
+Jupiter.colorBD: Yellow
+Jupiter.colorUL: Green
+Jupiter.cursorColor: Yellow
+
+! Hewlett Packard
+Tiburon.background: Black
+Tiburon.foreground: Magenta
+Tiburon.colorBD: Yellow
+Tiburon.colorUL: Red
+Tiburon.cursorColor: Yellow
+
+Pacifica.background: ForestGreen
+Pacifica.foreground: White
+Pacifica.colorBD: Yellow
+Pacifica.colorUL: Red
+Pacifica.cursorColor: Yellow
+
+plebld01.background: Black
+plebld01.foreground: Yellow
+plebld01.colorBD: Yellow
+plebld01.colorUL: Red
+plebld01.cursorColor: Yellow
+
+ccase-sj1-4.background: Black
+ccase-sj1-4.foreground: Green
+ccase-sj1-4.colorBD: Green
+ccase-sj1-4.colorUL: Red
+ccase-sj1-4.cursorColor: Yellow
+
+XServer.background: Black
+XServer.foreground: Green
+XServer.colorBD: Yellow
+XServer.colorUL: Red
+XServer.cursorColor: Yellow
+
+XLoad*background: Black
+XLoad*foreground: Yellow
+XLoad*highlight: Red
+XLoad*Label*Justify: center
--- /dev/null
+################################################################################
+#
+# File: $RCSfile: bash_login,v $
+# Revision: $Revision: 1.29 $
+# Description: bash startup file
+# Author: Andrew@DeFaria.com
+# Created: Mon Aug 20 17:35:01 2001
+# Modified: $Date: 2013/06/13 14:04:55 $
+# Language: bash
+#
+# (c) Copyright 2000-2005, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+# Set ARCH, architecture of the machine
+KERNEL=$(uname -s)
+if [[ $KERNEL = CYGWIN* ]]; then
+ export ARCH=cygwin
+elif [ $KERNEL = "Linux" ]; then
+ export ARCH=linux
+elif [ $KERNEL = "SunOS" ]; then
+ export ARCH=sun
+elif [ $KERNEL = "FreeBSD" ]; then
+ export ARCH=$KERNEL
+else
+ export ARCH=''
+ echo "Warning: Unknown architecture ($KERNEL)"
+fi
+
+# Architectual differences (AKA Silly Sun)
+if [ $ARCH = "sun" ]; then
+ alias id=/usr/xpg4/bin/id
+ alias tr=/usr/xpg4/bin/tr
+
+ export id=/usr/xpg4/bin/id
+fi
+
+# Set colors
+if [ -f "$HOME/.rc/set_colors" ]; then
+ source "$HOME/.rc/set_colors"
+else
+ echo "Warning: ~/.rc/set_colors does not exist!"
+fi
+
+# Check to see if we're interactive
+if [[ $- = *i* ]]; then
+ export interactive=true
+else
+ export interactive=false
+fi
+
+export VISUAL=vi
+
+# Terminal settings:
+if [ "$TERM" = "" -o \
+ "$TERM" = "unknown" -o \
+ "$TERM" = "dialup" -o \
+ "$TERM" = "network" ]; then
+ if [ "$interactive" = "true" ]; then
+ eval $(ttytype -s -a -t ansi -t hp)
+ fi
+fi
+
+# System dependent variables.
+if [ -f "$HOME/.rc/system" ]; then
+ source "$HOME/.rc/system"
+else
+ echo "Warning ~/.rc/system does not exist!"
+ export SYSNAME="*Unknown Systemname*:"
+fi
+
+# System dependencies
+# Note: I don't like doing this but an alias doesn't work...
+if [ $ARCH = "sun" ]; then
+ id=/usr/xpg4/bin/id
+else
+ id=id
+fi
+
+umask 002
+
+if [ "$interactive" = "true" ]; then
+ stty tostop intr ^C kill ^X susp ^Z erase ^H -inpck -istrip -ixany -echok -echonl
+fi
+
+# Set adm_base
+adm_base=${adm_base:-/opt/clearscm}
+
+# Set adm_fpath
+adm_fpath=${adm_fpath:-$adm_base/functions}
+
+# Source functions
+if [ -f "$adm_fpath/common" ]; then
+ source "$adm_fpath/common"
+else
+ : echo "Warning: Cannot find $adm_fpath/common!"
+fi
+
+# Source bash_completion (if present) (too slow for Windows)
+if [ -r /etc/bash_completion -a $ARCH != "cygwin" ]; then
+ source /etc/bash_completion
+fi
+
+export CVSROOT=:ext:andrew@clearscm.com:/var/cvs/cvsroot
+
+if [ -x ~/.rc/logout ]; then
+ trap "~/.rc/logout" 0
+fi
+
+# ClearCase Stuff
+if [ -f ~/.rc/clearcase ]; then
+ source ~/.rc/clearcase
+fi
+
+# MultiSite Stuff
+if [ -f ~/.rc/multisite ]; then
+ source ~/.rc/multisite
+fi
+
+# Import shell functions:
+if [ -f ~/.rc/functions ]; then
+ source ~/.rc/functions
+fi
+
+# Other settings:
+set -o emacs
+set -o monitor
+set +u
+
+shopt -s lithist
+
+# Aliases:
+if [ $ARCH = "FreeBSD" ]; then
+ alias ls="ls -FG"
+else
+ if [ -f ~/.rc/dircolors ]; then
+ if type -p dircolors > /dev/null; then
+ eval $(dircolors -b ~/.rc/dircolors)
+ fi
+ fi
+
+ if [ $ARCH = "sun" ]; then
+ # Ugh! --color doesn't work on braindead SUN
+ alias ls="ls -F"
+ else
+ alias ls="ls -F --color=auto"
+ fi
+fi
+
+alias ll="ls -la"
+alias whence="type -p"
+alias mroe=more
+
+if [ $ARCH = "cygwin" ]; then
+ alias host=nslookup
+fi
+
+export LANG=C
+
+if [ $(type -p vim) ]; then
+ alias vi=vim
+fi
+
+if [ $(type -p ncftp) ]; then
+ alias ftp=ncftp
+ alias ftpput=ncftpput
+ alias ftpget=ncftpget
+fi
+
+#alias grep="grep -d skip"
+
+if [ "$TERM" = "hpterm" -o \
+ "$TERM" = "hp" -o \
+ "$TERM" = "dtterm" -o \
+ "$TERM" = "sun-color" -o \
+ "$TERM" = "vt100" -o \
+ "$TERM" = "vt220" -o \
+ "$TERM" = "xterm" -o \
+ "$TERM" = "cygwin" ]; then
+ alias cd=mycd
+ alias pushd=mypushd
+ alias popd=mypopd
+fi
+
+# Miscellaneous:
+if [ -x $(type -p less) ]; then
+ export LESS=eiXP"?f%f :[stdin] .?pt(%pt\%):?bt(%bt bytes):-.."
+ alias more="less -sr"
+ export PAGER="less -sr"
+else
+ export MORE=-s
+ export PAGER=more
+fi
+
+export PS4='${0##*/} line $LINENO:'
+
+set_title
+set_prompt
+
+if [ "$TERM" = "dtterm" ]; then
+ export TERM=vt100
+ export DTTERM=True
+fi
+
+# Set mail
+export MAIL=/var/mail/$USER
+
+# Perl Environment
+export PERLCRITIC=~/.rc/perlcriticrc
+export PERLTIDY=~/.rc/perltidyrc
+
+# CDPATH
+export CDPATH="."
+
+alias vbs="cscript //nologo"
+
+# Set PATH
+if [ -f ~/.rc/set_path ]; then
+ source ~/.rc/set_path
+else
+ echo "Warning: ~/.rc/set_path does not exist!"
+fi
+
+# Color man pages with yellow keywords
+export LESS_TERMCAP_md=$'\e[1;33m'
+
+# Client specific customizations
+for script in $(\ls ~/.rc/client_scripts); do
+ # This is not working as long as ACLs are not supported from the remote
+ # NetApp. This happens at some clients where the home directory is on a
+ # Netapp and they do not support NTFS ACLs properly. We cannot determine
+ # if the script is executable.
+ #if [ ! -d ~/.rc/client_scripts/$script ]; then
+ if [ -x ~/.rc/client_scripts/$script -a \
+ ! -d ~/.rc/client_scripts/$script ]; then
+ source ~/.rc/client_scripts/$script
+ fi
+done
+
+# Set display to local
+export DISPLAY=${DISPLAY:-:0}
+
+# Now go home (in case we were not autmatically cd'ed there)
+if [ $(id -u) -ne 0 ]; then
+ cd
+fi
--- /dev/null
+#!/bin/bash
+################################################################################
+#
+# File: $RCSfile: clearcase,v $
+# Revision: $Revision: 1.33 $
+# Description: This script set up some useful environment variables and aliases
+# for Clearcase execution. File should be sourced (e.g .
+# clearcase)
+# Author: Andrew@DeFaria.com
+# Created: Wed Jun 5 21:08:03 PDT 1996
+# Modified: $Date: 2011/10/24 18:07:05 $
+# Language: bash
+#
+# (c) Copyright 2000-2011, ClearSCM, Inc., all rights reserved.
+#
+################################################################################
+# Set ARCH, architecture of the machine
+KERNEL=$(uname -s)
+
+if [[ $KERNEL = CYGWIN* ]]; then
+ export ARCH=cygwin
+ vobtagPrefix='\\\\\\\'
+elif [ $KERNEL = "Linux" ]; then
+ export ARCH=linux
+elif [ $KERNEL = "SunOS" ]; then
+ export ARCH=sun
+elif [ $KERNEL = "FreeBSD" ]; then
+ export ARCH=$KERNEL
+else
+ export ARCH=''
+ echo "Warning: Unknown architecture ($KERNEL)"
+fi
+
+if [ $ARCH = 'cygwin' ]; then
+ export CCHOME=$(cygpath -u "$(regtool get '/machine/SOFTWARE/Rational Software/RSINSTALLDIR' 2>/dev/null)"/Clearcase 2>/dev/null);
+else
+ export CCHOME="/opt/rational/clearcase"
+fi
+
+if [ ! -d "$CCHOME" ]; then
+ unset CCHOME
+# exit
+fi
+
+# Source in clearcase.conf
+if [ -f ~/.rc/clearcase.conf ]; then
+ source ~/.rc/clearcase.conf
+else
+ echo "WARNING: Could not find ~/.rc/clearcase.conf - functionality will be limted"
+fi
+
+export CLEARTOOL="$CCHOME/bin/cleartool"
+export CLEARCASE_BLD_HOST_TYPE="unix"
+
+if [ -f "$CCHOME/etc/utils/creds" ]; then
+ if [ $ARCH = 'cygwin' ]; then
+ alias creds=$(cygpath "$CCHOME/etc/utils/creds")
+ else
+ alias creds="$CCHOME/etc/utils/creds"
+ fi
+fi
+
+if [ -x "$CLEARTOOL" ]; then
+ export RGY="$CCHOME/var/atria/rgy"
+ export LOGS="$CCHOME/var/log"
+fi
+
+function scm {
+ scmstatus=0
+
+ if [ -x "$CLEARTOOL" ]; then
+ # Cleartool suddenly started appending ^M's (I think as of 7.1)
+ if [ $ARCH = 'cygwin' ]; then
+ # Need to set pipefail to pick up the exit code from cleartool
+ # otherwise we get the exit code from tr which is usually 0
+ set -o pipefail
+ "$CLEARTOOL" "$@" | tr -d "\015"
+ scmstatus=$?
+ set +o pipefail
+ else
+ "$CLEARTOOL" "$@"
+ scmstatus=$?
+ fi
+ else
+ scmstatus=1
+ fi
+
+ return $scmstatus
+} # scm
+
+function ct {
+ # Setview is special - there is no setview on Windows. But we approximate it
+ # with the function setview
+ if [ "$1" = "setview" ]; then
+ shift
+ setview "$@"
+ else
+ scm "$@"
+ fi
+
+ return $scmstatus
+} # ct
+
+function scmsystem {
+ if [ "$(scm pwv)" != '' ]; then
+ return 1
+ elif [ -f CVS/Root ]; then
+ return 2
+ else
+ return 0
+ fi
+} # scmsystem
+
+function ci {
+ if [ $# = 0 ]; then
+ echo "ci: Error: No files specified"
+ else
+ scm ci "$@"
+ fi
+} # ci
+
+function co {
+ if [ $# = 0 ]; then
+ echo "co: Error: No files specified"
+ else
+ scm co "$@"
+ fi
+} # co
+
+function unco {
+ if [ $# = 0 ]; then
+ echo "unco: Error: No files specified"
+ else
+ scm unco "$@"
+ fi
+} # unco
+
+function lslock {
+ scm lslock "$@"
+} # lslock
+
+function lllock {
+ scm lslock -long "$@"
+} # lllock
+
+# View related functions
+function setview {
+ if [ $ARCH = 'cygwin' ]; then
+ if [[ $1 = -* ]]; then
+ echo "The setview command with options is not supported on Windows"
+ return
+ fi
+
+ # Save off where we are
+ back=$PWD
+
+ # Start the view
+ scm startview "$@"
+
+ if [ $? != 0 ]; then
+ return $?
+ fi
+
+ # Setup $VOBTAG_PREFIX
+ mount -f -o binary M:/$1 $LINUX_VOBTAG_PREFIX
+
+ # Start a bash shell
+ bash
+
+ # Remove $LINUX_VOBTAG_PREFIX mount (Ignore errors)
+ umount $LINUX_VOBTAG_PREFIX 2> /dev/null
+
+ # Chdir back to were we started
+ cd $back
+ else
+ scm setview "$@"
+ fi
+
+ set_title
+ set_prompt
+} # setview
+
+function startview {
+ scm startview "$@"
+
+ mycd /view/$1
+} # startview
+
+function endview {
+ scm endview "$@"
+} # endview
+
+function killview {
+ scm endview -server "$@"
+} # killview
+
+function mkview {
+ scm mkview "$@"
+} # mkview
+
+function makeview {
+ if [ $# != 1 ]; then
+ echo "Usage: $FUNCNAME <stream>"
+ return 1
+ fi
+
+ stream=$1
+
+ # Check to see if the view already exists
+ scm lsview -short ${USER}_$stream > /dev/null 2>&1
+
+ if [ $? = 0 ]; then
+ echo "${USER}_$stream already exists!"
+ else
+ mkview -tag ${USER}_$stream -stream $stream@$pvob -stgloc -auto
+
+ if [ $? != 0 ]; then
+ echo "Couldn't find that stream. Perhaps it's one of these?"
+ let i=${#stream}-4
+ searchFor=${stream:1:$i}
+ scm lsstream -short -invob $pvob | grep $searchFor | $PAGER
+ return 0
+ fi
+ fi
+
+ setview ${USER}_$stream
+} # makeview
+
+function rmview {
+ scm rmview "$@"
+} # rmview
+
+function lsview {
+ if [ $# = 0 ]; then
+ scm lsview -s | $PAGER
+ elif [ $# = 1 ]; then
+ scm lsview -s | grep "$1"
+ else
+ scm lsview "$@"
+ fi
+} # lsview
+
+function myviews {
+ # Well they asked for my "views"...
+ if [ $(whence fortune) ]; then
+ fortune
+ echo
+ fi
+
+ # List my views and their associated activities
+ for view in $(scm lsview -s 2>&1 | grep $USER); do
+ headline=$(scm lsact -cact -fmt "%[headline]p" -view $view 2> /dev/null)
+
+ if [ "$headline" = "" ]; then
+ headline="<no activity set>"
+ fi
+
+ echo -e "$view\t$headline"
+ done
+} # myviews
+
+function llview {
+ if [ $# = 0 ]; then
+ scm lsview -long | $PAGER
+ else
+ scm lsview -long "$@"
+ fi
+} # llview
+
+function lsviews {
+ if [ $# = 0 ]; then
+ scm lsview -short
+ else
+ scm lsview -short | grep $1
+ fi
+} # lsviews
+
+# Vob related functions
+function lsvob {
+ if [ $# = 0 ]; then
+ scm lsvob | $PAGER
+ elif [ $# = 1 ]; then
+ scm lsvob | grep "$1"
+ else
+ scm lsvob "$@"
+ fi
+} # lsvob
+
+function llvob {
+ if [ $# = 0 ]; then
+ scm lsvob -long | $PAGER
+ else
+ scm lsvob -long "$@"
+ fi
+} # llvob
+
+function lsvobs {
+ if [ $# = 0 ]; then
+ scm lsvob -short
+ else
+ scm lsvob -short | grep $1
+ fi
+} # lsvobs
+
+# Config spec functions
+function setcs {
+ scm setcs "$@"
+} # setcs
+
+function edcs {
+ scm edcs "$@"
+} # edcs
+
+function catcs {
+ scm catcs "$@"
+} # catcs
+
+function pwv {
+ scm pwv -s "$@"
+} # pwv
+
+function rmtag {
+ scm rmtag "$@"
+} # rmtag
+
+function mktag {
+ scm mktag "$@"
+} # mktag
+
+function describe {
+ scm describe "$@"
+} # describe
+
+function desc {
+ scm describe "$@"
+} # describe
+
+function oid2name {
+ if [ $# == 2 ]; then
+ oid=$1
+ projvob=$2
+ elif [ $# == 1 ]; then
+ oid=$1
+ projvob=$pvob
+ else
+ echo "Usage: oid2name: <oid> [<pvob>]"
+
+ return
+ fi
+
+ scm describe oid:$oid@$projvob 2> /dev/null | head -1
+} # oid2name
+
+function name2oid {
+ if [ $# == 3 ]; then
+ type=$1
+ name=$2
+ projvob=$3
+ elif [ $# == 2 ]; then
+ type=$1
+ name=$2
+ projvob=$pvob
+ else
+ echo "Usage: name2oid: <type> <name> [<pvob>]"
+
+ return
+ fi
+
+ scm dump $type:$name@$projvob 2> /dev/null | grep oid=
+} # name2oid
+
+# Action functions
+function vtree {
+ if [ $# != 1 ]; then
+ echo "vtree: Error: Must specify an element to view its version tree"
+ else
+ if [ $ARCH = 'cygwin' ]; then
+ scm lsvtree -g "$@"
+ else
+ xlsvtree "$@"
+ fi
+ fi
+} # vtree
+
+function merge {
+ scm merge "$@"
+} # merge
+
+function findmerge {
+ scm findmerge "$@"
+} # findmerge
+
+function cdiff {
+ scmsystem; scmtype=$?
+
+ if [ $# = 1 ]; then
+ if [ $scmtype = 1 ]; then
+ scm diff -graphical -pred $1
+ elif [ $scmtype = 2 ]; then
+ cvs diff $1
+ fi
+ else
+ if [ $scmtype = 1 ]; then
+ scm diff -graphical "$@"
+ elif [ $scmtype = 2 ]; then
+ cvs diff "$@"
+ fi
+ fi
+} # cdiff
+
+function ctdiff {
+ if [ $# = 1 ]; then
+ scm xdiff -vstack -pred $1
+ else
+ scm xdiff -vstack $@
+ fi
+} # ctdiff
+
+# Administrative functions
+function space {
+ scm space "$@"
+} # space
+
+function register {
+ scm register "$@"
+} # register
+
+function unregister {
+ scm unregister "$@"
+} # unregister
+
+# Information functions
+function hostinfo {
+ scm hostinfo "$@"
+} # hostinfo
+
+function lstrig {
+ if [ $# = 2 ]; then
+ trig_name=$1
+ vob=$2
+ scm lstype trtype:$trig_name@$vob
+ else
+ scm lstype -kind trtype "$@" | $PAGER
+ fi
+} # lstrig
+
+function lltrig {
+ if [ $# = 1 ]; then
+ scm lstype -long trtype:$1
+ else
+ scm lstype -long -kind trtype "$@"| $PAGER
+ fi
+} # lltrig
+
+function lsbr {
+ scm lstype -brtype
+} # lsbr
+
+function lslab {
+ scm lstype -lbtype
+} # lslab
+
+# UCM oriented functions
+function lsstream {
+ if [ $# = 0 ]; then
+ # If we are in a view context then try to list the stream for our view
+ if [[ $(pwv) == "** NONE **" ]]; then
+ lsstreams | $PAGER
+ else
+ scm lsstream | $PAGER
+ fi
+ else
+ # Check to see if a pvob was specified
+ if [[ $@ == *@* ]]; then
+ scm lsstream "$@"
+ else
+ scm lsstream -invob $pvob | grep $1 | $PAGER
+ fi
+ fi
+} # lsstream
+
+function llstream {
+ if [ $# = 0 ]; then
+ scm lsstream -l | $PAGER
+ else
+ scm lsstream -l "$@"
+ fi
+} # llstream
+
+function lsstreams {
+ if [ $# = 0 ]; then
+ scm lsstream -short -invob $pvob
+ else
+ scm lsstream -short "$@"
+ fi
+} # lstreams
+
+function lsregions () {
+ if [ $# -gt 0 ]; then
+ scm lsregion -short | grep ^$1
+ else
+ scm lsregion -short
+ fi
+} # lsregions
+
+function rebase {
+ scm rebase "$@"
+} # rebase
+
+function deliver {
+ scm deliver "$@"
+} # deliver
+
+function lsbl {
+ scm lsbl "$@"
+} # lsbl
+
+function lsll {
+ scm lsbl -lon "$@"
+} # llbl
+
+function lsproj {
+ if [ $# = 0 ]; then
+ scm lsproject | $PAGER
+ else
+ scm lsproject "$@"
+ fi
+} # lsproj
+
+function llproj {
+ if [ $# = 0 ]; then
+ scm lsproject -l | $PAGER
+ else
+ scm lsproject -l "$@"
+ fi
+} # llproj
+
+function lsfolder {
+ scm lsfolder "$@"
+} # lsfolder
+
+function llfolder {
+ scm lsfolder -long "$@"
+} # llfolder
+
+function lsstgloc {
+ if [ $# = 0 ]; then
+ scm lsstgloc | $PAGER
+ else
+ scm lsstgloc "$@"
+ fi
+} # lsstgloc
+
+function llstgloc {
+ if [ $# = 0 ]; then
+ scm lsstgloc -l | $PAGER
+ else
+ scm lsstgloc -l "$@"
+ fi
+} # llstgloc
+
+function lsact {
+ if [ $# = 0 ]; then
+ scm lsactivity | $PAGER
+ else
+ scm lsactivity "$@"
+ fi
+} # lsact
+
+function llact {
+ if [ $# = 0 ]; then
+ scm lsactivity -l | $PAGER
+ else
+ scm lsactivity -l "$@"
+ fi
+} # llact
+
+function setact {
+ if [ $# = 0 ]; then
+ echo "What? Am I suppose to guess?!?"
+ exit 1
+ else
+ scm setactivity "$@"
+ fi
+} # setact
+
+function clist {
+ scmsystem; scmtype=$?
+
+ if [ $scmtype = 1 ]; then
+ scm lsco -short -cview -all -me
+ elif [ $scmtype = 2 ]; then
+ cvs -Q status | grep ^File | grep -v Up-to-date
+ fi
+} # clist
+
+function ciwork {
+ scm ci -cq $(clist)
+} # ciwork
+
+# Bash completion for Clearcase commands. T
+
+# Add "," to COMP_BREAKWORDS
+COMP_WORDBREAKS=\ \"\'\>\<\=\;\|\&\(\:\,
+
+# All Clearcase commands
+_scm_cmds="\
+annotate \
+catcr \
+catcs \
+cd \
+chactivity \
+chbl \
+checkin \
+checkout \
+checkvob \
+chevent \
+chflevel \
+chfolder \
+chmaster \
+chpool \
+chproject \
+chstream \
+chtype \
+chview \
+ci \
+co \
+cptype \
+deliver \
+describe \
+diff \
+diffbl \
+diffcr \
+dospace \
+edcs \
+endview \
+file \
+find \
+findmerge \
+get \
+getcache \
+getlog \
+help \
+hostinfo \
+ln \
+lock \
+ls \
+lsactivity \
+lsbl \
+lscheckout \
+lscheckout \
+lsclients \
+lscomp \
+lsdo \
+lsfolder \
+lshistory \
+lslock \
+lsmaster \
+lspool \
+lsprivate \
+lsproject \
+lsregion \
+lsreplica \
+lssite \
+lsstgloc \
+lsstream \
+lstype \
+lstype \
+lsview \
+lsvob \
+lsvtree \
+man \
+merge \
+mkactivity \
+mkattr \
+mkattype \
+mkbl \
+mkbranch \
+mkbrtype \
+mkcomp \
+mkdir \
+mkelem \
+mkeltype \
+mkfolder \
+mkhlink \
+mkhltype \
+mklabel \
+mklbtype \
+mkpool \
+mkproject \
+mkregion \
+mkstgloc \
+mkstream \
+mktag \
+mktrigger \
+mktrtype \
+mkview \
+mkvob \
+mount \
+move \
+protect \
+protectvob \
+pwd \
+pwv \
+quit \
+rebase \
+recoverview \
+reformatview \
+reformatvob \
+register \
+relocate \
+rename \
+reqmaster \
+reserve \
+rmactivity \
+rmattr \
+rmbl \
+rmbranch \
+rmcomp \
+rmdo \
+rmelem \
+rmfolder \
+rmhlink \
+rmlabel \
+rmmerge \
+rmname \
+rmpool \
+rmproject \
+rmregion \
+rmstgloc \
+rmstream \
+rmtag \
+rmtrigger \
+rmtype \
+rmver \
+rmview \
+rmvob \
+schedule \
+setactivity \
+setcache \
+setcs \
+setplevel \
+setsite \
+setview \
+space \
+startview \
+umount \
+uncheckout \
+unlock \
+unregister \
+unreserve \
+update \
+winkin \
+"
+# Kinds
+_kinds="\
+attype \
+brtype \
+eltype \
+hltype \
+lbtype \
+trtype \
+"
+# Type selectors
+_type_selectors="\
+attype: \
+brtype: \
+eltype: \
+hltype: \
+lbtype: \
+trtype: \
+"
+# These options are common to all scm commands. So far -help is the only one
+_global_opts="\
+-help \
+"
+# Comment opts. These options are common for commands that request the user
+# specify a comment
+_comment_opts="\
+-c \
+-cfile \
+-cq \
+-cqe \
+-nc \
+"
+# Individual command options
+_annotate_opts="\
+$_global_opts \
+-all \
+-fmt \
+-force \
+-long \
+-nco \
+-ndata \
+-nheader \
+-out \
+-rm \
+-rmfmt \
+-short \
+"
+_catcr_opts="\
+$_global_opts \
+-check \
+-ci \
+-critical \
+-element \
+-flat \
+-follow \
+-long \
+-makefile \
+-name \
+-nxname \
+-recurse \
+-scripts \
+-select \
+-short \
+-type \
+-union \
+-view \
+-wd \
+-zero \
+"
+_chbl_opts="\
+$_global_opts \
+$_comment_opts \
+-full \
+-incremental \
+-level \
+-nrecurse \
+"
+_checkout_opts="\
+$_global_opts \
+$_comment_opts \
+-branch \
+-ndata \
+-nmaster \
+-nquery \
+-nwarn \
+-out \
+-ptime \
+-query \
+-reserved \
+-unreserved \
+-usehijack \
+-version \
+"
+_chflevel_opts="\
+$_global_opts \
+-auto \
+-family \
+-force \
+-master \
+-override \
+-replica \
+"
+_chpool_opts="\
+$_global_opts \
+$_comment_opts \
+-force \
+"
+_chtype_opts="\
+$_global_opts \
+$_comment_opts \
+-force \
+-pname \
+"
+_diff_opts="\
+$_global_opts \
+-graphical \
+-hstack \
+-options \
+-predecessor \
+-serial \
+-tiny \
+"
+_diffbl_opts="\
+$_global_opts \
+-activities \
+-baselines \
+-first \
+-graphical \
+-nmerge \
+-nrecurse \
+-predecessor \
+-versions \
+"
+_diffcr_opts="\
+$_global_opts \
+-ci \
+-critical \
+-element \
+-follow \
+-long \
+-name \
+-nxname \
+-recurse \
+-select \
+-short \
+-type \
+-view \
+-wd \
+"
+_edcs_opts="\
+$_global_opts \
+-ctime \
+-overwrite \
+-ptime \
+-rename \
+-tag \
+"
+_deliver_opts="\
+$_global_opts \
+-abort \
+-activities \
+-baseline \
+-cact \
+-cancel \
+-complete \
+-force \
+-gmerge \
+-graphical \
+-long \
+-ok \
+-preview \
+-qall \
+-qntrivial \
+-query \
+-reset \
+-resume \
+-serial \
+-short \
+-status \
+-stream \
+-target \
+-to \
+"
+_diff_opts="\
+$_global_opts \
+-columns \
+-diff \
+-graphical \
+-hstack \
+-options \
+-predecessor \
+-serial \
+-tiny \
+-vstack \
+"
+_diffbl_opts="\
+$_global_opts \
+-activities \
+-baselines \
+-elements \
+-first \
+-graphical \
+-nmerge \
+-nrecurse \
+-predecessor \
+-versions \
+"
+_diffcr="\
+$_global_opts \
+-ci \
+-critical \
+-element \
+-flat \
+-follow \
+-long \
+-name \
+-nxname \
+-recurse \
+-select \
+-short \
+-type \
+-view \
+-wd \
+"
+_dospace_opts="\
+$_global_opts \
+-all \
+-before \
+-dump \
+-generate \
+-pool \
+-references \
+-region \
+-scrub \
+-since \
+-size \
+-top \
+-update \
+"
+_find_opts="\
+$_global_opts \
+-all \
+-avobs \
+-branch \
+-cview \
+-depth \
+-directory \
+-element \
+-exec \
+-follow \
+-group \
+-kind \
+-name \
+-nrecurse \
+-nvisible \
+-nxname \
+-ok \
+-type \
+-user \
+-version \
+-visible \
+"
+_mkelem_opts="\
+$_global_opts \
+-c \
+-cfile \
+-ci \
+-cq \
+-cqe \
+-eltype \
+-master \
+-mkpath \
+-nc \
+-nco \
+-nwarn \
+"
+_findmerge_opts="\
+$_global_opts \
+$_comment_opts \
+-abort \
+-all \
+-avobs \
+-blank \
+-depth \
+-directory \
+-element \
+-exec \
+-fbtag \
+-fcsets \
+-flatest \
+-follow \
+-ftag \
+-graphical \
+-group \
+-log \
+-long \
+-name \
+-nback \
+-nrecurse \
+-nxname \
+-nzero \
+-ok \
+-okgmerge \
+-okmerge \
+-qall \
+-qntrivial \
+-query \
+-serial \
+-short \
+-type \
+-unreserved \
+-user \
+-visible \
+-whynot \
+"
+_get_opts="\
+$_global_opts \
+-to \
+"
+_getcache_opts="\
+$_global_opts \
+-all \
+-host \
+-mvfs \
+-persistent \
+-reset \
+-short \
+-site \
+-view \
+"
+_ln_opts="\
+$_global_opts \
+$_comment_opts \
+-force \
+-nco \
+-slink \
+"
+_ls_opts="\
+$_global_opts \
+-directory \
+-long \
+-nxname \
+-recurse \
+-short \
+-view_only \
+-visibile \
+-vob_only \
+"
+_lscheckout_opts="\
+$_global_opts \
+-all \
+-areplicas \
+-avobs \
+-brtype \
+-cview \
+-directory \
+-fmt \
+-graphical \
+-long \
+-me \
+-recurse \
+-short \
+-user \
+"
+_lsdo_opts="\
+$_global_opts \
+-fmt \
+-long \
+-me \
+-nshareable_dos \
+-recurse \
+-short \
+-sname \
+-stime \
+-zero \
+"
+_lshistory_opts="\
+$_global_opts \
+-all \
+-avobs \
+-branch \
+-directory \
+-eventid \
+-fmt \
+-graphical \
+-last \
+-local \
+-long \
+-me \
+-minor \
+-nco \
+-nopreferences \
+-pname \
+-recurse \
+-short \
+-since \
+-user \
+"
+_lslock_opts="\
+$_global_opts \
+-all \
+-fmt \
+-local \
+-long \
+-obsolete \
+-pname \
+-short \
+"
+_lsmaster_opts="\
+$_global_opts \
+-all \
+-fmt \
+-inreplicas \
+-kind \
+-view \
+"
+_lsreplica_opts="\
+$_global_opts \
+-all \
+-fmt \
+-inreplicas \
+-invob \
+-long \
+-short \
+-siblings \
+"
+_lssite_opts="\
+$_global_opts \
+-inquire \
+-setting-name \
+"
+_lsstream_opts="\
+$_global_opts \
+-ancestor \
+-cview \
+-depth \
+-fmt \
+-in \
+-invob \
+-long \
+-obsolete \
+-recurse \
+-short \
+-template \
+-tree \
+-view \
+"
+_lsvtree_opts="\
+$_global_opts \
+-all \
+-branch \
+-graphical \
+-merge \
+-nco \
+-nmerge \
+-nrecurse \
+-obsolete \
+-short \
+"
+_merge_opts="\
+$_global_opts \
+-abort \
+-base \
+-c \
+-cfile \
+-columns \
+-cq \
+-cqe \
+-delete \
+-diff \
+-graphical \
+-insert \
+-narrows \
+-nc \
+-ndata \
+-options \
+-out \
+-qall \
+-qntrivial \
+-query \
+-replace \
+-serial \
+-tiny \
+-to \
+-version \
+"
+_mkattr_opts="\
+$_global_opts \
+$_comment_opts \
+-ci \
+-config \
+-default \
+-name \
+-pname \
+-replace \
+-select \
+-type \
+-version \
+"
+_mkattype_opts="\
+$_global_opts \
+$_comment_opts \
+-acquire \
+-default
+-enum \
+-ge \
+-global \
+-gt \
+-le
+-lt
+-ordinary \
+-replace \
+-shared \
+-vpbranch \
+-vpelement \
+-vpversion \
+-vtype \
+"
+_mkbranch_opts="\
+$_global_opts \
+$_comment_opts \
+-nco \
+-nwarn \
+-ptime \
+-version \
+"
+_mkbrtype_opts="\
+$_global_opts \
+-acquire \
+-global \
+-ordinary \
+-pbranch \
+-replace \
+"
+_mkdir_opts="\
+$_global_opts \
+$_comment_opts \
+-master \
+-nco \
+"
+_mkelem_opts="\
+$_global_opts \
+$_comment_opts \
+-ci \
+-eltype \
+-master \
+-mkpath \
+-nco \
+-nwarn \
+-ptime \
+"
+_mkeltype_opts="\
+$_global_opts \
+$_comment_opts \
+-acquire \
+-global \
+-manager \
+-mergetype \
+-ordinary \
+-ptime \
+-replace \
+-supertype \
+"
+_mkhlink_opts="\
+$_global_opts \
+$_comment_opts \
+-acquire \
+-fpname \
+-ftext \
+-tpname \
+-ttext \
+-unidir \
+"
+_mkhltype_opts="\
+$_global_opts \
+$_comment_opts \
+-acquire \
+-global \
+-ordinary \
+-replace \
+-shared \
+"
+_mklabel_opts="\
+$_global_opts \
+$_comment_opts \
+-ci \
+-config \
+-follow \
+-name \
+-nc \
+-recurse \
+-replace \
+-select \
+-type \
+-version \
+"
+_mklbtype_opts="\
+$_global_opts \
+$_comment_opts \
+-acquire \
+-global \
+-ordinary \
+-pbranch \
+-replace \
+-shared \
+"
+_mkpool_opts="\
+$_global_opts \
+$_comment_opts \
+-age \
+-alert \
+-cleartext \
+-ln \
+-size \
+-source \
+-update \
+"
+_mktrigger_opts="\
+$_global_opts \
+$_comment_opts \
+-force \
+-nattach \
+-ninherit \
+-recurse \
+"
+_move_opts="\
+$_global_opts \
+$_comment_opts \
+"
+_protect_opts="\
+$_global_opts \
+$_comment_opts \
+-chgrp \
+-chmod \
+-chown \
+-directory \
+-file \
+-pname \
+-recurse \
+"
+_protectvob_opts="\
+$_global_opts \
+-add_group \
+-chgrp \
+-chown \
+-delete_group \
+-force \
+-nremote_admin \
+-remote_admin \
+"
+_pwv_opts="\
+-root \
+-setview \
+-short \
+-wdview \
+"
+_relocate_opts="\
+$_global_opts \
+-force \
+-log \
+-qall \
+-update \
+"
+_rename_opts="\
+$_global_opts \
+$_comment_opts \
+-acquire \
+"
+_reqmaster_opts="\
+$_global_opts \
+$_comment_opts \
+-acl \
+-allow \
+-deny \
+-disable \
+-edit \
+-enable \
+-get \
+-instances \
+-list \
+-set \
+"
+_reserve_opts="\
+$_global_opts \
+$_comment_opts \
+-cact \
+"
+_rmbranch_opts="\
+$_global_opts \
+$_comment_opts \
+-force \
+"
+_rmdo_opts="\
+$_global_opts \
+-all \
+-before \
+-since \
+-zero \
+"
+_rmelem_opts="\
+$_global_opts \
+$_comment_opts \
+-force \
+"
+_rmmerge_opts="\
+$_global_opts \
+$_comment_opts \
+"
+_rmname_opts="\
+$_global_opts \
+$_comment_opts \
+-force \
+"
+_rmpool_opts="\
+$_global_opts \
+$_comment_opts \
+"
+_rmstream_opts="\
+$_global_opts \
+$_comment_opts \
+"
+_rmver_opts="\
+$_global_opts \
+$_comment_opts \
+-data \
+-force \
+-version \
+-vrange \
+-xattr \
+-xbranch \
+-xhlink \
+-xlabel \
+"
+_schedule_opts="\
+$_global_opts \
+-acl \
+-delete \
+-edit \
+-force \
+-get \
+-host \
+-job \
+-run \
+-schedule \
+-set \
+-status \
+-tasks \
+-wait \
+"
+_setactivity_opts="\
+$_global_opts \
+$_comment_opts \
+-none \
+-view \
+"
+_setcache_opts="\
+$_global_opts \
+-acache \
+-cachesize \
+-cto \
+-cview \
+-cvpfreemax \
+-cvpfreemin \
+-default \
+-dirdnc \
+-dncache \
+-host \
+-mnmax \
+-mvfs \
+-nacache \
+-ncto \
+-ndncachez \
+-noentdnc \
+-nrlcache \
+-nrvcache \
+-password \
+-persistent \
+-persistent_only \
+-readdir_blocks \
+-regdnc \
+-rlcache \
+-rpchandles \
+-rvcache \
+-scalefactor \
+-site \
+-view \
+-vobfreemax \
+-vobfreemin \
+-zone \
+"
+_setsite_opts="\
+$_global_opts \
+-password \
+"
+_uncheckout_opts="\
+$_global_opts \
+-cact \
+-keep \
+-rm \
+-unco \
+"
+_unregister_opts="\
+$_global_opts \
+-uuid \
+-view \
+-vob \
+"
+_unreserve_opts="\
+$_global_opts \
+$_comment_opts \
+-cact \
+-view \
+"
+_update_opts="\
+$_global_opts \
+-add_loadrules \
+-ctime \
+-force \
+-graphical \
+-log \
+-noverwrite \
+-overwrite \
+-print \
+-ptime \
+-rename \
+"
+_winkin_opts="\
+$_global_opts \
+-adirs \
+-adirs \
+-ci \
+-noverwrite \
+-out \
+-print \
+-recurse \
+-select \
+-siblings \
+"
+
+_object_selectors="\
+activity: \
+attype: \
+baseline: \
+brtype: \
+component: \
+eltype: \
+folder: \
+hlink: \
+hltype: \
+lbtype: \
+oid: \
+pool: \
+project: \
+replica: \
+stream: \
+trtype: \
+vob: \
+"
+
+_operation_types="\
+chactivity \
+chbl \
+checkin \
+checkout \
+chevent \
+chfolder \
+chmaster \
+chproject \
+chstream \
+chtype \
+deliver_cancel \
+deliver_complete \
+deliver_start \
+lnname \
+lock \
+mkactivity \
+mkattr \
+mkbl \
+mkbl_complete \
+mkbranch \
+mkcomp \
+mkelem \
+mkfolder \
+mkhlink \
+mklabel \
+mkproject \
+mkslink \
+mkstream \
+mktrigger \
+protect \
+rebase_cancel \
+rebase_complete \
+rebase_start \
+reserve \
+rmactivity \
+rmattr \
+rmbranch \
+rmcl \
+rmcomp \
+rmelem \
+rmfolder \
+rmhlink \
+rmlabel \
+rmname \
+rmproject \
+rmstream \
+rmtrigger \
+rmver \
+setactivity \
+setactivity_none \
+setplevel \
+uncheckout \
+unlock \
+unreserve \
+"
+
+if [ $ARCH = 'cygwin' ]; then
+ _arch_policies="\
+POLICY_WIN_INT_SNAP \
+POLICY_WIN_DEV_SNAP \
+"
+else
+ _arch_policies="\
+POLICY_UNIX_INT_SNAP \
+POLICY_UNIX_DEV_SNAP \
+"
+fi
+
+_policies="\
+$arch_policies \
+POLICY_CHPROJECT_UNRESTRICED \
+POLICY_DELIVER_REQUIRE_REBASE \
+POLICY_DELIVER_NCO_DEVSTR \
+POLICY_DELIVER_NOCO_SELACTS \
+POLICY_REBASE_CO \
+POLICY_INTRAPROJECT_DELIVER_FOUNDATION_CHANGES \
+POLICY_INTRAPROJECT_DELIVER_ALLOW_MISSING_TGTCOMPS \
+POLICY_INTERPROJECT_DELIVER \
+POLICY_INTERPROJECT_DELIVER_FOUNDATION_CHANGES \
+POLICY_INTERPROJECT_DELIVER_REQUIRE_TGTCOMP_VISIBIITY \
+POLICY_INTERPROJECT_DELIVER_ALLOW_NONMOD_TGTCOMPS \
+"
+
+# Helper functions
+function set_pvob () {
+ if [ $# -eq 1 ]; then
+ pvob=$1
+ fi
+} # set_pvob
+
+function set_dvob () {
+ if [ $# -eq 1 ]; then
+ dvob=$1
+ fi
+} # set_dvob
+
+# Listing type functions. These functions produce a list of some object and are
+# used by the various completion functions.
+function _attypes () {
+ if [ $# -gt 0 ]; then
+ scm lstype -kind attype -invob $pvob -fmt "%n " | grep ^$1
+ else
+ scm lstype -kind attype -invob $pvob -fmt "%n "
+ fi
+} # _attypes
+
+function _activities () {
+ if [ $# -gt 0 ]; then
+ scm lsactivity -short -invob $pvob | grep ^$1 | sed "s:$:@$vobtagPrefix$pvob:"
+ else
+ scm lsactivity -short -invob $pvob | sed "s:$:@$vobtagPrefix$pvob:"
+ fi
+} # _activities
+
+function _baselines () {
+ stream=$(scm lsstream -short 2> /dev/null)
+
+ if [ -z $stream ]; then
+ return;
+ fi
+
+ if [ $# -ge 0 ]; then
+ scm lsbl -stream $stream@$pvob -short | grep ^$1 | sed "s:$:@$vobtagPrefix$pvob:"
+ else
+ scm lsbl -stream $stream@$pvob -short | sed "s:$:@$vobtagPrefix$pvob:"
+ fi
+} # _baselines
+
+function _brtypes () {
+ if [ $# -gt 0 ]; then
+ scm lstype -kind brtype -invob $pvob -fmt "%n\n" | grep ^$1
+ else
+ scm lstype -kind brtype -invob $pvob -fmt "%n\n"
+ fi
+} # _brtypes
+
+function _cchosts () {
+ registryHost=$(scm hostinfo -long | grep "Registry host:" | awk '{print $NF}')
+
+ scm lsclients -short -host $registryHost | tr [:upper:] [:lower:]
+} # _cchosts
+
+function _components () {
+ if [ $# -gt 0 ]; then
+ scm lscomp -short -invob $pvob | grep ^$1 | sed "s:$:@$vobtagPrefix$pvob:"
+ else
+ scm lscomp -short -invob $pvob | sed "s:$:@$vobtagPrefix$pvob:"
+ fi
+} # _components
+
+function _eltypes () {
+ if [ $# -gt 0 ]; then
+ scm lstype -kind eltype -invob $pvob -fmt "%n " | grep ^$1
+ else
+ scm lstype -kind eltype -invob $pvob -fmt "%n "
+ fi
+} # _eltypes
+
+function _folders () {
+ if [ $# -gt 0 ]; then
+ scm lsfolder -short -invob $pvob | grep ^$1 | sed "s:$:@$vobtagPrefix$pvob:"
+ else
+ scm lsfolder -short -invob $pvob | sed "s:$:@$vobtagPrefix$pvob:"
+ fi
+} # _folders
+
+function _hltypes () {
+ if [ $# -gt 0 ]; then
+ scm lstype -kind hltype -invob $pvob -fmt "%n " | grep ^$1
+ else
+ scm lstype -kind hltype -invob $pvob -fmt "%n "
+ fi
+} # _hltypes
+
+function _lbtypes () {
+ if [ $# -gt 0 ]; then
+ scm lstype -kind lbtype -invob $pvob -fmt "%n@$vobtagPrefix$pvob " | grep ^$1
+ else
+ scm lstype -kind lbtype -invob $pvob -fmt "%n@$vobtagPrefix$pvob "
+ fi
+} # _lbtypes
+
+function _projects () {
+ if [ $# -gt 0 ]; then
+ scm lsproject -short -invob $pvob | grep ^$1 | sed "s:$:@$vobtagPrefix$pvob:"
+ else
+ scm lsproject -short -invob $pvob | sed "s:$:@$vobtagPrefix$pvob:"
+ fi
+} # _projects
+
+function _streams () {
+ if [ $# -gt 0 ]; then
+ scm lsstream -short -invob $pvob | grep ^$1 | sed "s:$:@$vobtagPrefix$pvob:"
+ else
+ scm lsstream -short -invob $pvob | sed "s:$:@$vobtagPrefix$pvob:"
+ fi
+} # _streams
+
+function _stglocs () {
+ if [ $# -gt 0 ]; then
+ scm lsstgloc -short | grep ^$1
+ else
+ scm lsstgloc -short
+ fi
+} # _stglocs
+
+function _views () {
+ if [ $# -gt 0 ]; then
+ scm lsview -short | grep ^$1;
+ else
+ scm lsview -short;
+ fi
+} # _views
+
+function _vobs () {
+ # We simply must rid ourselves of these bloody backlashes!!! And yet Clearcase
+ # insists on retaining them. Let's strip them off, do our thing, then put them
+ # back to backslashes when we output stuff.
+ if [ $ARCH = 'cygwin' ]; then
+ if [ $# -eq 0 ]; then
+ scm lsvob -short | sed 's:\\:\\\\\\\\:'
+ else
+ # Convert to foward slashes
+ vob=$(echo $1 | sed 's:\\::g')
+
+ scm lsvob -short | sed 's:\\::' | grep ^$vob | sed 's:^:\\\\\\\\:'
+ fi
+ else
+ if [ $# -eq 0 ]; then
+ scm lsvob -short
+ else
+ scm lsvob -short | grep ^$1
+ fi
+ fi
+} # _vobs
+
+function _trtypes () {
+ if [ $# -gt 0 ]; then
+ scm lstype -kind trtype -invob $pvob -fmt "%n " | grep ^$1
+ else
+ scm lstype -kind trtype -invob $pvob -fmt "%n "
+ fi
+} # _trtypes
+
+# Completion functions for individual commands where the completion may change
+# depending on the operation. For example, typing "scm catcs -tag " should
+# now complete based on view tags whereas "scm catcs -" should just complete
+# based on options (which are only -help and -tag at this point for this
+# particular command). If a command does not have a "completer function" then
+# it will only provide for options completion and will be handled by the general
+# _scm completion function.
+function _catcs () {
+ local cur prev
+ local opts="\
+$_global_opts \
+-tag \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $prev == -tag ]]; then
+ COMPREPLY=($(compgen -W "$(lsviews)" -- $cur))
+ fi
+} # _catcs
+
+function _chactivity () {
+ local cur prev
+ local opts="\
+$_global_opts \
+$_comment_opts \
+-headline \
+-fcset \
+-tcset \
+-view \
+-cqaction \
+-cact \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $prev == -fcset || $prev == -tcset ]]; then
+ COMPREPLY=($(compgen -W "$(_activities $cur)"))
+ elif [[ $prev == -view ]]; then
+ COMPREPLY=($(compgen -W "$(lsviews)" -- $cur))
+ fi
+} # _chactivity
+
+function _checkin () {
+ local cur prev prev2
+ local opts="\
+$_global_opts \
+$_comment_opts \
+-cact \
+-cr \
+-from \
+-identical \
+-keep \
+-ptime \
+-rm \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+ prev2="${COMP_WORDS[COMP_CWORD-2]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $prev2 == activity && $prev == : ]]; then
+ COMPREPLY=($(compgen -W "$(_activities $cur)"))
+ fi
+} # _checkin
+
+function _checkvob () {
+ local cur prev
+ local opts="\
+$_global_opts \
+-acquire \
+-activity \
+-cleartext \
+-component \
+-crm \
+-data \
+-debris \
+-derived \
+-fix \
+-force \
+-from \
+-global \
+-hlinks \
+-hltype \
+-ignore \
+-lock \
+-log \
+-pname \
+-pool \
+-protections \
+-setup \
+-source \
+-to \
+-trssize \
+-ucm \
+-unlock \
+-verbose \
+-view \
+-vob \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $prev == -view ]]; then
+ COMPREPLY=($(compgen -W "$(lsviews)" -- $cur))
+ fi
+} # _checkvob
+
+function _chevent () {
+ local cur prev
+ local opts="\
+$_global_opts \
+$_comment_opts \
+-append \
+-event \
+-insert \
+-invob \
+-pname \
+-replace \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $prev == -invob ]]; then
+ COMPREPLY=($(compgen -W "$(_vobs $cur)"))
+ elif [[ $cur == * ]]; then
+ COMPREPLY=($(compgen -W "$_object_selectors" -- $cur))
+ fi
+} # _chevent
+
+function _chfolder () {
+ local cur prev
+ local opts="\
+$_global_opts \
+$_comment_opts \
+-to \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $prev == -to ]]; then
+ COMPREPLY=($(compgen -W "$(_folders $cur)"))
+ elif [[ $cur == * ]]; then
+ COMPREPLY=($(compgen -W "$(_folders $cur)"))
+ fi
+} # _chfolder
+
+function _chmaster () {
+ local cur prev
+ local opts="\
+$_global_opts \
+$_comment_opts \
+-all \
+-default \
+-long \
+-obsolete_replica \
+-override \
+-pname \
+-stream \
+-view \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $prev == -stream ]]; then
+ COMPREPLY=($(compgen -W "$(_streams $cur)"))
+ elif [[ $cur == -view ]]; then
+ COMPREPLY=($(compgen -W "$(lsviews)" -- $cur))
+ fi
+} # _chmaster
+
+function _chproject () {
+ local cur prev
+ local opts="\
+$_global_opts \
+$_comment_opts \
+-amodcomp \
+-blname \
+-connection \
+-crmenable \
+-custom \
+-dmodcomp \
+-ncrmenable \
+-npolicy \
+-policy \
+-rebase \
+-spolicy \
+-template \
+-to \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $prev == -amodcomp ||
+ $prev == -dmodcomp ]]; then
+ COMPREPLY=($(compgen -W "$(_components $cur)"))
+ elif [[ $prev == -to ]]; then
+ COMPREPLY=($(compgen -W "$(_folders $cur)"))
+ elif [[ $prev == -policy ||
+ $prev == -npolicy ||
+ $prev == -spolicy ]]; then
+ COMPREPLY=($(compgen -W "$_policies" -- $cur))
+ elif [[ $cur == * ]]; then
+ COMPREPLY=($(compgen -W "$(_projects $cur)"))
+ fi
+} # _chproject
+
+function _chstream () {
+ local cur prev
+ local opts="\
+$_global_opts \
+$_comment_opts \
+-amodcomp \
+-cview \
+-default \
+-dmodcomp \
+-generate \
+-npolicy \
+-nrecommended \
+-ntarget \
+-policy \
+-recommended \
+-target \
+-template \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $prev == -amodcomp ||
+ $prev == -dmodcomp ]]; then
+ COMPREPLY=($(compgen -W "$(_components $cur)"))
+ elif [[ $prev == -policy ||
+ $prev == -npolicy ]]; then
+ COMPREPLY=($(compgen -W "$_policies" -- $cur))
+ elif [[ $prev == , || $prev == -recommended || $cur == , ]]; then
+ if [[ $cur == , ]]; then
+ cur=''
+ fi
+ COMPREPLY=($(compgen -W "$(_baselines $cur)"))
+ elif [[ $prev == -target || $cur == * ]]; then
+ COMPREPLY=($(compgen -W "$(_streams $cur)"))
+ fi
+} # _chstream
+
+function _chview () {
+ local cur prev
+ local opts="\
+$_global_opts \
+-cachesize \
+-cview \
+-force \
+-nshareable \
+-readonly \
+-readwrite \
+-shareable \
+-stream \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $prev == -stream ]]; then
+ COMPREPLY=($(compgen -W "$(_streams $cur)"))
+ elif [[ $prev == * ]]; then
+ COMPREPLY=($(compgen -W "$(lsviews)" -- $cur))
+ fi
+} # _chview
+
+function _deliver () {
+ local cur prev
+ local opts="\
+$_global_opts \
+-activities \
+-cact \
+-complete \
+-force \
+-gmerge \
+-graphical \
+-query \
+-reset \
+-serial \
+-stream \
+-target \
+-to \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $prev == -stream || $prev == -target ]]; then
+ COMPREPLY=($(compgen -W "$(_streams $cur)"))
+ elif [[ $prev == -to ]]; then
+ COMPREPLY=($(compgen -W "$(lsviews)" -- $cur))
+ elif [[ $prev == -activities ]]; then
+ COMPREPLY=($(compgen -W "$(_activities $cur)"))
+ fi
+} # _deliver
+
+function _describe () {
+ local cur prev
+ local opts="\
+$_global_opts \
+-aattr \
+-ahlink \
+-alabel \
+-aliases \
+-all \
+-cact \
+-cview \
+-graphical \
+-ihlink \
+-local \
+-long \
+-pname \
+-predecessor \
+-type \
+-version \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $cur == * ]]; then
+ COMPREPLY=($(compgen -W "$_object_selectors" -- $cur))
+ fi
+} # _describe
+
+function _dospace () {
+ local cur prev
+ local opts="\
+$_global_opts \
+-before \
+-pool \
+-references \
+-region \
+-scrub \
+-since \
+-size \
+-top \
+-update \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $prev == -region ]]; then
+ COMPREPLY=($(compgen -W "$(lsregions)" -- $cur))
+ fi
+} # _dospace
+
+function _edcs () {
+ local cur prev
+ local opts="\
+$_global_opts \
+-ctime \
+-overwrite \
+-ptime \
+-rename \
+-tag \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $prev == -tag ]]; then
+ COMPREPLY=($(compgen -W "$(lsviews)" -- $cur))
+ fi
+} # _edcs
+
+function _endview () {
+ local cur prev
+ local opts="\
+$_global_opts \
+-server \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $prev == * ]]; then
+ COMPREPLY=($(compgen -W "$(lsviews)" -- $cur))
+ fi
+} # _endview
+
+function _file () {
+ local cur prev
+ local opts="\
+$_global_opts \
+-all \
+-invob \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $prev == -invob ]]; then
+ COMPREPLY=($(compgen -W "$(_vobs $cur)"))
+ fi
+} # _file
+
+function _getlog () {
+ local cur prev
+ local opts="\
+$_global_opts \
+-all \
+-around \
+-cview \
+-full \
+-graphical \
+-host \
+-inquire \
+-last \
+-since \
+-tag \
+-vob \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $prev == -tag || $prev == -target ]]; then
+ COMPREPLY=($(compgen -W "$(lsviews)" -- $cur))
+ elif [[ $prev == -vob ]]; then
+ COMPREPLY=($(compgen -W "$(_vobs $cur)"))
+ elif [[ $prev == -host ]]; then
+ COMPREPLY=($(compgen -W "$(_cchosts)" -- $cur))
+ fi
+} # _getlog
+
+function _hostinfo () {
+ local cur prev
+ local opts="\
+$_global_opts \
+-full \
+-long \
+-properties \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $cur == * ]]; then
+ COMPREPLY=($(compgen -W "$(_cchosts)" -- $cur))
+ fi
+} # _hostinfo
+
+function _lsactivity () {
+ local cur prev
+ local opts="\
+$_global_opts \
+-ancestor \
+-cact \
+-contrib \
+-cview \
+-depth \
+-fmt \
+-fmt \
+-in \
+-invob \
+-long \
+-me \
+-obsolete \
+-recurse \
+-short \
+-user \
+-view \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $prev == -invob ]]; then
+ COMPREPLY=($(compgen -W "$(_vobs $cur)"))
+ elif [[ $prev == -in ]]; then
+ COMPREPLY=($(compgen -W "$(_streams $cur)"))
+ elif [[ $prev == -view ]]; then
+ COMPREPLY=($(compgen -W "$(lsviews)" -- $cur))
+ elif [[ $cur == * ]]; then
+ COMPREPLY=($(compgen -W "$(_activities $cur)"))
+ fi
+} # _lsactivity
+
+function _lsbl () {
+ local cur prev
+ local opts="\
+$_global_opts \
+-component \
+-cview \
+-fmt \
+-gtlevel \
+-level \
+-long \
+-long \
+-ltlevel \
+-obsolete \
+-recurse \
+-short \
+-stream \
+-tree \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $prev == -component ]]; then
+ COMPREPLY=($(compgen -W "$(_components $cur)"))
+ elif [[ $prev == -stream ]]; then
+ COMPREPLY=($(compgen -W "$(_streams $cur)"))
+ fi
+} # _lsbl
+
+function _lsclients () {
+ local cur prev
+ local opts="\
+$_global_opts \
+-host \
+-type \
+-short \
+-long \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $prev == -host ]]; then
+ COMPREPLY=($(compgen -W "$(_cchosts $cur)"))
+ fi
+} # _lsclients
+
+function _lscomp () {
+ local cur prev
+ local opts="\
+$_global_opts \
+-fmt \
+-invob \
+-long \
+-obsolete \
+-short \
+-tree \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $prev == -invob ]]; then
+ COMPREPLY=($(compgen -W "$(_vobs $cur)"))
+ elif [[ $cur == * ]]; then
+ COMPREPLY=($(compgen -W "$(_components $cur)"))
+ fi
+} # _lscomp
+
+function _lsfolder () {
+ local cur prev
+ local opts="\
+$_global_opts \
+-ancestor \
+-cview \
+-depth \
+-fmt \
+-in \
+-invob \
+-obsolete \
+-recurse \
+-short \
+-tree \
+-view \
+"
+ local lopts="$opts -long"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ if [[ $prev == -llfolder ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ else
+ COMPREPLY=($(compgen -W "$lopts" -- $cur))
+ fi
+ elif [[ $prev == -invob ]]; then
+ COMPREPLY=($(compgen -W "$(_vobs $cur)"))
+ elif [[ $prev == -view ]]; then
+ COMPREPLY=($(compgen -W "$(lsviews)" -- $cur))
+ elif [[ $prev == -in || $cur == * ]]; then
+ COMPREPLY=($(compgen -W "$(_folders $cur)"))
+ fi
+} # _lsfolder
+
+function _lspool () {
+ local cur prev
+ local opts="\
+$_global_opts \
+-fmt \
+-invob \
+-long \
+-obsolete \
+-short \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $prev == -invob ]]; then
+ COMPREPLY=($(compgen -W "$(_vobs $cur)"))
+ fi
+} # _lspool
+
+function _lsprivate () {
+ local cur prev
+ local opts="\
+$_global_opts \
+-age \
+-co \
+-do \
+-invob \
+-long \
+-other \
+-short \
+-size \
+-tag \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $prev == -tag ]]; then
+ COMPREPLY=($(compgen -W "$(lsviews)" -- $cur))
+ elif [[ $prev == -invob ]]; then
+ COMPREPLY=($(compgen -W "$(_vobs $cur)"))
+ fi
+} # _lsprivate
+
+function _lsproject () {
+ local cur prev
+ local opts="\
+$_global_opts \
+-ancestor \
+-custom \
+-cview \
+-depth \
+-fmt \
+-in \
+-invob \
+-long \
+-obsolete \
+-recurse \
+-short \
+-template \
+-tree \
+-view \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $prev == -view ]]; then
+ COMPREPLY=($(compgen -W "$(lsviews)" -- $cur))
+ elif [[ $prev == -invob ]]; then
+ COMPREPLY=($(compgen -W "$(_vobs $cur)"))
+ elif [[ $prev == -in || $cur == * ]]; then
+ COMPREPLY=($(compgen -W "$(_folders $cur)"))
+ fi
+} # _lsproject
+
+function _lsregion () {
+ local cur prev
+ local opts="\
+$_global_opts \
+-long \
+-short \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $prev == * ]]; then
+ regions=$(scm lsregion -short | grep ^$cur)
+ COMPREPLY=($(compgen -W "$regions" -- $cur))
+ fi
+} # _lsregion
+
+function _lsstgloc () {
+ local cur prev
+ local opts="\
+$_global_opts \
+-host \
+-long \
+-region \
+-short \
+-storage \
+-view \
+-vob \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $prev == -region ]]; then
+ COMPREPLY=($(compgen -W "$(_regions $cur)" -- $cur))
+ elif [[ $prev == -storage ]]; then
+ COMPREPLY=($(compgen -W "$(_stglocs $cur)"))
+ elif [[ $prev == -host ]]; then
+ _cchosts
+ fi
+} # _lsstgloc
+
+function _lsstream () {
+ local cur prev
+ local opts="\
+$_global_opts \
+-ancestor \
+-cview \
+-depth \
+-fmt \
+-in \
+-invob \
+-obsolete \
+-recurse \
+-short \
+-template \
+-tree \
+-view \
+"
+ local lopts="$opts -long"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ if [[ $prev == llstream ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ else
+ COMPREPLY=($(compgen -W "$lopts" -- $cur))
+ fi
+ elif [[ $prev == -in ]]; then
+ COMPREPLY=($(compgen -W "$(_projects $cur)"))
+ elif [[ $prev == -invob ]]; then
+ COMPREPLY=($(compgen -W "$(_vobs $cur)"))
+ elif [[ $prev == -view ]]; then
+ COMPREPLY=($(compgen -W "$(lsviews)"))
+ elif [[ $cur == * ]]; then
+ COMPREPLY=($(compgen -W "$(_streams $cur)"))
+ fi
+} # _lsstream
+
+function _lstype () {
+ local cur prev
+ local opts="\
+$_global_opts \
+-fmt \
+-graphical \
+-invob \
+-kind \
+-local \
+-long \
+-nostatus \
+-obsolete \
+-short \
+-unsorted \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $prev == -kind ]]; then
+ COMPREPLY=($(compgen -W "$_kinds" -- $cur))
+ elif [[ $prev == -invob ]]; then
+ COMPREPLY=($(compgen -W "$(_vobs $cur)"))
+ elif [[ $cur == * ]]; then
+ _type_selector
+ fi
+} # _lstype
+
+function _lsview () {
+ local cur prev
+ local opts="\
+$_global_opts \
+-age \
+-cview \
+-full \
+-host \
+-properties \
+-quick \
+-region \
+-short \
+-storage \
+-text \
+-uuid \
+"
+ local lopts="$opts -long"
+
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ if [[ $prev == llview ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ else
+ COMPREPLY=($(compgen -W "$lopts" -- $cur))
+ fi
+ elif [[ $prev == -region ]]; then
+ COMPREPLY=($(compgen -W "$(_regions $cur)" -- $cur))
+ elif [[ $prev == -host ]]; then
+ COMPREPLY=($(compgen -W "$(_cchosts $cur)"))
+ elif [[ $cur == * ]]; then
+ COMPREPLY=($(compgen -W "$(lsviews)" -- $cur))
+ fi
+} # _lsview
+
+function _lsvob () {
+ local cur prev
+ local opts="\
+$_global_opts \
+-family \
+-graphical \
+-host \
+-quick \
+-region \
+-short \
+-storage \
+-uuid \
+"
+ lopts="$opts -long"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ if [[ $prev == llvob ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ else
+ COMPREPLY=($(compgen -W "$lopts" -- $cur))
+ fi
+ elif [[ $prev == -region ]]; then
+ COMPREPLY=($(compgen -W "$(_regions $cur)"))
+ elif [[ $prev == -host ]]; then
+ COMPREPLY=($(compgen -W "$(_cchosts $cur)"))
+ elif [[ $cur == * ]]; then
+ COMPREPLY=($(compgen -W "$(_vobs $cur)"))
+ fi
+} # _lsvob
+
+function _mkactivity () {
+ local cur prev
+ local opts="\
+$_global_opts \
+-force \
+-headline \
+-in \
+-nset \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $prev == -in ]]; then
+ COMPREPLY=($(compgen -W "$(_streams $cur)"))
+ fi
+} # _mkactivity
+
+function _mkbl () {
+ local cur prev
+ local opts="\
+$_global_opts \
+-activities \
+-adepends \
+-all \
+-component \
+-ddepends \
+-full \
+-identical \
+-import \
+-incremental \
+-nact \
+-nlabel \
+-view \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $prev == -activities ]]; then
+ COMPREPLY=($(compgen -W "$(_activities $cur)"))
+ elif [[ $prev == -component ||
+ $prev == -adepends_on ||
+ $prev == -ddepends_on ]]; then
+ COMPREPLY=($(compgen -W "$(_components $cur)"))
+ elif [[ $prev == -clone ]]; then
+ COMPREPLY=($(compgen -W "$(_baselines $cur)"))
+ elif [[ $prev == -view ]]; then
+ COMPREPLY=($(compgen -W "$(lsviews)" -- $cur))
+ fi
+} # _mkbl
+
+function _mkcomp () {
+ local cur prev
+ local opts="\
+$_global_opts \
+-nroot \
+-root \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $cur == * ]]; then
+ COMPREPLY=($(compgen -W "$(_components $cur)"))
+ fi
+} # _mkcomp
+
+function _mkfolder () {
+ local cur prev
+ local opts="\
+$_global_opts \
+-in \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $prev == -in ||
+ $cur == * ]]; then
+ COMPREPLY=($(compgen -W "$(_folders $cur)"))
+ fi
+} # _mkfolder
+
+function _mkproject () {
+ local cur prev
+ local opts="\
+$_global_opts \
+-blname \
+-connection \
+-crmenable \
+-custom \
+-in \
+-modcomp \
+-model \
+-npolicy \
+-policy \
+-spolicy \
+-template \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $prev == -modcomp ]]; then
+ COMPREPLY=($(compgen -W "$(_components $cur)"))
+ elif [[ $prev == -in ]]; then
+ COMPREPLY=($(compgen -W "$(_folders $cur)"))
+ elif [[ $prev == -policy ||
+ $prev == -npolicy ||
+ $prev == -spolicy ]]; then
+ COMPREPLY=($(compgen -W "$_policies" -- $cur))
+ fi
+} # _mkproject
+
+function _mkregion () {
+ local cur prev
+ local opts="\
+$_global_opts \
+-replace \
+-tag \
+-tcomment \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $prev == -tag ]]; then
+ COMPREPLY=($(compgen -W "$(_regions $cur)" -- $cur))
+ fi
+} # _mkregion
+
+function _mkstgloc () {
+ local cur prev
+ local opts="\
+$_global_opts \
+-comment \
+-force \
+-gpath \
+-host \
+-hpath \
+-ngpath \
+-region \
+-view \
+-vob \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $prev == -region ]]; then
+ COMPREPLY=($(compgen -W "$(_regions $cur)" -- $cur))
+ elif [[ $prev == -host ]]; then
+ COMPREPLY=($(compgen -W "$(_cchosts $cur)"))
+ fi
+} # _mkstgloc
+
+function _mkstream () {
+ local cur prev
+ local opts="\
+$_global_opts \
+-amodcomp \
+-baseline \
+-in \
+-integration \
+-nc \
+-npolicy \
+-policy \
+-readonly \
+-target \
+-template \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $prev == -amodcomp ]]; then
+ COMPREPLY=($(compgen -W "$(_components $cur)"))
+ elif [[ $prev == -baseline ]]; then
+ COMPREPLY=($(compgen -W "$(_baselines $cur)"))
+ elif [[ $prev == -in ]]; then
+ COMPREPLY=($(compgen -W "$(_projects $cur)"))
+ elif [[ $prev == -policy ||
+ $prev == -npolicy ]]; then
+ COMPREPLY=($(compgen -W "$(_policies $cur)" -- $cur))
+ fi
+} # _mkstream
+
+function _mktag () {
+ local cur prev
+ local opts="\
+$_global_opts \
+-gpath \
+-host \
+-nstart \
+-options \
+-password \
+-public \
+-region \
+-replace \
+-tag \
+-tcomment \
+-view \
+-vob \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+ prev2="$(COMP_WORDS[COMP_CWORD-2])"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $prev2 == -view && $prev == "-tag" ]]; then
+ COMPREPLY=($(compgen -W "$(lsviews)" -- $cur))
+ elif [[ $prev2 == -vob && $prev == "-tag" ]]; then
+ COMPREPLY=($(compgen -W "$(_vobs $cur)"))
+ elif [[ $prev == -region ]]; then
+ COMPREPLY=($(compgen -W "$(_regions $cur)" -- $cur))
+ elif [[ $prev == -host ]]; then
+ COMPREPLY=($(compgen -W "$(_cchosts $cur)"))
+ fi
+} # _mktag
+
+function _mktrtype () {
+ local cur prev
+ local opts="\
+$_global_opts \
+-activity \
+-all \
+-attype \
+-baseline \
+-brtype \
+-component \
+-eltype \
+-execunix \
+-execwin \
+-folder \
+-hltype \
+-lbtype \
+-mkattr \
+-mkhlink \
+-mklabel \
+-nc \
+-nusers \
+-postop \
+-print \
+-project \
+-replace \
+-stream \
+-trtype \
+-type \
+-ucmobject \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $prev == -preop ||
+ $prev == -postopt ]]; then
+ COMPREPLY=($(compgen -W "$_operation_types" -- $cur))
+ elif [[ $prev == -project ]]; then
+ COMPREPLY=($(compgen -W "$(_projects $cur)"))
+ elif [[ $prev == -stream ]]; then
+ COMPREPLY=($(compgen -W "$(_streams $cur)"))
+ elif [[ $prev == -component ]]; then
+ COMPREPLY=($(compgen -W "$(_components $cur)"))
+ elif [[ $prev == -folder ]]; then
+ COMPREPLY=($(compgen -W "$(_folders $cur)"))
+ elif [[ $prev == -activity ]]; then
+ COMPREPLY=($(compgen -W "$(_activites $cur)" -- $cur))
+ elif [[ $prev == -baseline ]]; then
+ COMPREPLY=($(compgen -W "$(_baselines $cur)"))
+ elif [[ $prev == -attype ]]; then
+ COMPREPLY=($(compgen -W "$(_attypes $cur)"))
+ elif [[ $prev == -brtype ]]; then
+ COMPREPLY=($(compgen -W "$(_brtypes $cur)"))
+ elif [[ $prev == -eltype ]]; then
+ COMPREPLY=($(compgen -W "$(_eltypes $cur)"))
+ elif [[ $prev == -hltype ]]; then
+ COMPREPLY=($(compgen -W "$(_hltypes $cur)"))
+ elif [[ $prev == -lbtype ]]; then
+ COMPREPLY=($(compgen -W "$(_lbtypes $cur)"))
+ elif [[ $prev == -trtypes ]]; then
+ COMPREPLY=($(compgen -W "$(_trtypes $cur)"))
+ fi
+} # _mktrtype
+
+function _mkview () {
+ local cur prev
+ local opts="\
+$_global_opts \
+-auto \
+-cachesize \
+-colocated \
+-gpath \
+-host \
+-hpath \
+-nshareable \
+-ptime \
+-region \
+-shareable \
+-snapshot \
+-stgloc \
+-stream \
+-tag \
+-tcomment \
+-tmode \
+-vws \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $prev == -tag ]]; then
+ COMPREPLY=($(compgen -W "$(lsviews)" -- $cur))
+ elif [[ $prev == -region ]]; then
+ COMPREPLY=($(compgen -W "$(_regions $cur)" -- $cur))
+ elif [[ $prev == -stgloc ]]; then
+ COMPREPLY=($(compgen -W "$(_stglocs $cur)"))
+ elif [[ $prev == -host ]]; then
+ COMPREPLY=($(compgen -W "$(_cchosts $cur)"))
+ fi
+} # _mkview
+
+function _mkvob () {
+ local cur prev
+ local opts="\
+$_global_opts \
+-auto \
+-gpath \
+-host \
+-hpath \
+-nc \
+-nremote \
+-options \
+-password \
+-public \
+-region \
+-stgloc \
+-tag \
+-tcomment \
+-ucmproject \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $prev == -tag ]]; then
+ COMPREPLY=($(compgen -W "$(_vobs $cur)"))
+ elif [[ $prev == -region ]]; then
+ COMPREPLY=($(compgen -W "$(_regions $cur)" -- $cur))
+ elif [[ $prev == -stgloc ]]; then
+ COMPREPLY=($(compgen -W "$(_stglocs $cur)"))
+ elif [[ $prev == -host ]]; then
+ COMPREPLY=($(compgen -W "$(_cchosts $cur)"))
+ fi
+} # _mkvob
+
+function _mount () {
+ local cur prev
+ local opts="\
+$_global_opts \
+-all \
+-options \
+-persistent \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $cur == * ]]; then
+ COMPREPLY=($(compgen -W "$(_vobs $cur)"))
+ fi
+} # _mount
+
+function _rebase () {
+ local cur prev
+ local opts="\
+$_global_opts \
+-abort \
+-baseline \
+-cancel \
+-complete \
+-dbaseline \
+-force \
+-gmerge \
+-graphical \
+-long \
+-ok \
+-preview \
+-qall \
+-qntrivial \
+-query \
+-recommended \
+-resume \
+-serial \
+-short \
+-status \
+-stream \
+-view \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $prev == -view ]]; then
+ COMPREPLY=($(compgen -W "$(lsviews)" -- $cur))
+ elif [[ $prev == -stream ]]; then
+ COMPREPLY=($(compgen -W "$(_streams $cur)"))
+ elif [[ $prev == -baseline ||
+ $prev == -dbaseline ]]; then
+ COMPREPLY=($(compgen -W "$(_baselines $cur)"))
+ fi
+} # _rebase
+
+function _recoverview () {
+ local cur prev
+ local opts="\
+$_global_opts \
+-directory \
+-force \
+_synchronize \
+-tag \
+-vob \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $prev == -tag ]]; then
+ COMPREPLY=($(compgen -W "$(lsviews)" -- $cur))
+ elif [[ $prev == -vob ]]; then
+ COMPREPLY=($(compgen -W "$(_vobs $cur)"))
+ fi
+} # _recoverview
+
+function _reformatview () {
+ local cur prev
+ local opts="\
+$_global_opts \
+-dump \
+-load \
+-tag \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $prev == -tag ]]; then
+ COMPREPLY=($(compgen -W "$(lsviews)" -- $cur))
+ fi
+} # _reformatview
+
+function _reformatvob () {
+ local cur prev
+ local opts="\
+$_global_opts \
+-dump \
+-force \
+-host \
+-hpath \
+-load \
+-rm \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $prev == -host ]]; then
+ COMPREPLY=($(compgen -W "$(_cchosts $cur)"))
+ fi
+} # _reformatvob
+
+function _register () {
+ local cur prev
+ local opts="\
+$_global_opts \
+-host \
+-hpath \
+-replace \
+-ucmproject \
+-view \
+-vob \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $prev == -host ]]; then
+ COMPREPLY=($(compgen -W "$(_cchosts $cur)"))
+ fi
+} # _register
+
+function _rmactivity () {
+ local cur prev
+ local opts="\
+$_global_opts \
+$_comment_opts \
+-force \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $cur == * ]]; then
+ COMPREPLY=($(compgen -W "$(_activities $cur)"))
+ fi
+} # _rmactivity
+
+function _rmattr () {
+ local cur prev
+ local opts="\
+$_global_opts \
+$_comment_opts \
+-recurse \
+-version \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $cur == * ]]; then
+ COMPREPLY=($(compgen -W "$(_attypes $cur)"))
+ fi
+} # _rmattr
+
+function _rmbl () {
+ local cur prev
+ local opts="\
+$_global_opts \
+$_comment_opts \
+-force\
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $cur == * ]]; then
+ COMPREPLY=($(compgen -W "$(_baselines $cur)"))
+ fi
+} # _rmbl
+
+function _rmcomp () {
+ local cur prev
+ local opts="\
+$_global_opts \
+$_comment_opts \
+-force\
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $cur == * ]]; then
+ COMPREPLY=($(compgen -W "$(_components $cur)"))
+ fi
+} # _rmcomp
+
+function _rmfolder () {
+ local cur prev
+ local opts="\
+$_global_opts \
+$_comment_opts \
+-force\
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $cur == * ]]; then
+ COMPREPLY=($(compgen -W "$(_folders $cur)"))
+ fi
+} # _rmfolder
+
+function _rmhlink () {
+ local cur prev
+ local opts="\
+$_global_opts \
+$_comment_opts \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $cur == * ]]; then
+ COMPREPLY=($(compgen -W "$(_hltypes $cur)"))
+ fi
+} # _rmhlink
+
+function _rmlabel () {
+ local cur prev
+ local opts="\
+$_global_opts \
+$_comment_opts \
+-follow \
+-recurse \
+-version \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $cur == * ]]; then
+ COMPREPLY=($(compgen -W "$(_lbtypes $cur)"))
+ fi
+} # _rmlabel
+
+function _rmproject () {
+ local cur prev
+ local opts="\
+$_global_opts \
+$_comment_opts \
+-force \
+-template \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $cur == * ]]; then
+ COMPREPLY=($(compgen -W "$(_projects $cur)"))
+ fi
+} # _rmproject
+
+function _rmregion () {
+ local cur prev
+ local opts="\
+$_global_opts \
+-password \
+-rmall \
+-tag \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $prev == -tag ]]; then
+ COMPREPLY=($(compgen -W "$(_regions $cur)" -- $cur))
+ fi
+} # _rmregion
+
+function _rmstgloc () {
+ local cur prev
+ local opts="\
+$_global_opts \
+-all \
+-region \
+-storage \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $prev == -region ]]; then
+ COMPREPLY=($(compgen -W "$(_regions $cur)" -- $cur))
+ elif [[ $cur == * ]]; then
+ COMPREPLY=($(compgen -W "$(_stglocs $cur)"))
+ fi
+} # _rmstgloc
+
+function _rmstream () {
+ local cur prev
+ local opts="\
+$_global_opts \
+$_comment_opts \
+-force \
+-template \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $cur == * ]]; then
+ COMPREPLY=($(compgen -W "$(_streams $cur)"))
+ fi
+} # _rmstream
+
+function _rmtag () {
+ local cur prev
+ local opts="\
+$_global_opts \
+-all \
+-region \
+-view \
+-vob \
+-password \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $prev == -view ]]; then
+ COMPREPLY=($(compgen -W "$(lsviews)" -- $cur))
+ elif [[ $prev == -vob ]]; then
+ COMPREPLY=($(compgen -W "$(_vobs $cur)"))
+ elif [[ $prev == -region ]]; then
+ COMPREPLY=($(compgen -W "$(_regions $cur)" -- $cur))
+ fi
+} # _rmtag
+
+function _rmtrigger () {
+ local cur prev
+ local opts="\
+$_global_opts \
+$_comment_opts \
+-nattach \
+-ninherit \
+-recurse \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $cur == * ]]; then
+ COMPREPLY=($(compgen -W "$(_trtypes $cur)"))
+ fi
+} # _rmtrigger
+
+function _rmtype () {
+ local cur prev
+ local opts="\
+$_global_opts \
+$_comment_opts \
+-force \
+-ignore \
+-rmall \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $cur == * ]]; then
+ _type_selectors
+ fi
+} # _rmtype
+
+function _rmview () {
+ local cur prev
+ local opts="\
+$_global_opts \
+$_comment_opts \
+-all \
+-avobs \
+-force \
+-tag \
+-vob \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $prev == -tag ]]; then
+ COMPREPLY=($(compgen -W "$(lsviews)" -- $cur))
+ elif [[ $prev == -vob ]]; then
+ COMPREPLY=($(compgen -W "$(_vobs $cur)"))
+ fi
+} # _rmview
+
+function _rmvob () {
+ local cur prev
+ local opts="\
+$_global_opts \
+-force \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $cur == * ]]; then
+ COMPREPLY=($(compgen -W "$(_vobs $cur)"))
+ fi
+} # _rmvob
+
+function _setcs () {
+ local cur prev
+ local opts="\
+$_global_opts \
+-ctime \
+-current \
+-default \
+-force \
+-overwrite \
+-pname \
+-ptime \
+-rename \
+-stream \
+-tag \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $cur == -tag ]]; then
+ COMPREPLY=($(compgen -W "$(lsviews)" -- $cur))
+ fi
+} # _setcs
+
+function _setplevel () {
+ local cur prev
+ local opts="\
+$_global_opts \
+$_comment_opts \
+-default \
+-invob \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $prev == -invob ]]; then
+ COMPREPLY=($(compgen -W "$(_vobs $cur)"))
+ fi
+} # _setplevel
+
+function _setview() {
+ local cur prev
+ local opts="\
+$_global_opts \
+-login \
+-exec \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* && $ARCH != cygwin ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $cur == * ]]; then
+ COMPREPLY=($(compgen -W "$(_views $cur)"))
+ fi
+} # _setview
+
+function _space () {
+ local cur prev
+ local opts="\
+$_global_opts \
+-all \
+-directory \
+-generate \
+-host \
+-region \
+-scrub \
+-update \
+-view \
+-vob \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $prev == -view ]]; then
+ COMPREPLY=($(compgen -W "$(lsviews)" -- $cur))
+ elif [[ $prev == -vob || $cur == * ]]; then
+ COMPREPLY=($(compgen -W "$(_vobs $cur)"))
+ fi
+} # _space
+
+function _startview () {
+ local cur prev
+ local opts="\
+$_global_opts \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $cur == * ]]; then
+ COMPREPLY=($(compgen -W "$(lsviews)" -- $cur))
+ fi
+} # _startview
+
+function _umount () {
+ local cur prev
+ local opts="\
+$_global_opts \
+-all
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $cur == * ]]; then
+ COMPREPLY=($(compgen -W "$(_vobs $cur)"))
+ fi
+} # _umount
+
+function _unlock () {
+ local cur prev
+ local opts="\
+$_global_opts \
+$_comment_opts \
+-pname \
+-version \
+"
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+
+ if [[ $cur == -* ]]; then
+ COMPREPLY=($(compgen -W "$opts" -- $cur))
+ elif [[ $cur == * ]]; then
+ COMPREPLY=($(compgen -W "$(_object_selector $cur)" -- $cur))
+ fi
+} # _unlock
+
+function _scm () {
+ local cur prev
+
+ COMPREPLY=()
+ cur="${COMP_WORDS[COMP_CWORD]}"
+ cmd="${COMP_WORDS[0]}"
+ subcmd="${COMP_WORDS[1]}"
+
+ if [[ $cmd == scm || $cmd == ct ]]; then
+ if [[ $COMP_CWORD == 1 ]]; then
+ COMPREPLY=($(compgen -W "$_scm_cmds" -- $cur))
+ else
+ case "$subcmd" in
+ annotate)
+ COMPREPLY=($(compgen -W "$_annotate_opts" -- $cur));;
+ catcr)
+ COMPREPLY=($(compgen -W "$_catcr_opts" -- $cur));;
+ catcs)
+ _catcs;;
+ chactivity)
+ _chactivity;;
+ chbl)
+ COMPREPLY=($(compgen -W "$_chbl_opts" -- $cur));;
+ checkin|ci)
+ _checkin;;
+ checkout|co)
+ COMPREPLY=($(compgen -W "$_checkout_opts" -- $cur));;
+ checkvob)
+ _checkvob;;
+ chevent)
+ _chevent;;
+ chflevel)
+ COMPREPLY=($(compgen -W "$_chflevel_opts" -- $cur));;
+ chfolder)
+ _chfolder;;
+ chmaster)
+ _chmaster;;
+ chpool)
+ COMPREPLY=($(compgen -W "$_chpool_opts" -- $cur));;
+ chproject)
+ _chproject;;
+ chstream)
+ _chstream;;
+ chtype)
+ COMPREPLY=($(compgen -W "$_chtype_opts" -- $cur));;
+ chview)
+ _chview;;
+ deliver)
+ _deliver;;
+ describe|desc)
+ _describe;;
+ diff)
+ COMPREPLY=($(compgen -W "$_diff_opts" -- $cur));;
+ diffbl)
+ COMPREPLY=($(compgen -W "$_diffbl_opts" -- $cur));;
+ diffcr)
+ COMPREPLY=($(compgen -W "$_diffcr_opts" -- $cur));;
+ dospace)
+ _dospace;;
+ edcs)
+ _edcs;;
+ endview)
+ _endview;;
+ file)
+ _file;;
+ find)
+ COMPREPLY=($(compgen -W "$_find_opts" -- $cur));;
+ findmerge)
+ COMPREPLY=($(compgen -W "$_findmerge_opts" -- $cur));;
+ get)
+ COMPREPLY=($(compgen -W "$_get_opts" -- $cur));;
+ getcache)
+ COMPREPLY=($(compgen -W "$_getcache_opts" -- $cur));;
+ getlog)
+ _getlog;;
+ help)
+ COMPREPLY=($(compgen -W "$_scm_cmds" -- $cur));;
+ hostinfo)
+ _hostinfo;;
+ ln)
+ COMPREPLY=($(compgen -W "$_ln_opts" -- $cur));;
+ ls)
+ COMPREPLY=($(compgen -W "$_ls_opts" -- $cur));;
+ lsactivity)
+ _lsactivity;;
+ lsbl)
+ _lsbl;;
+ lscheckout|lsco)
+ COMPREPLY=($(compgen -W "$_lscheckout_opts" -- $cur));;
+ lsclients)
+ lsclients;;
+ lscomp)
+ _lscomp;;
+ lsdo)
+ COMPREPLY=($(compgen -W "$_lsdo_opts" -- $cur));;
+ lsfolder)
+ _lsfolder;;
+ lshistory)
+ COMPREPLY=($(compgen -W "$_lshistory_opts" -- $cur));;
+ lslock)
+ COMPREPLY=($(compgen -W "$_lslock_opts" -- $cur));;
+ lsmaster)
+ COMPREPLY=($(compgen -W "$_lsmaster_opts" -- $cur));;
+ lspool)
+ _lspool;;
+ lsprivate)
+ _lsprivate;;
+ lsproject)
+ _lsproject;;
+ lsregion)
+ _lsregion;;
+ lsreplica)
+ COMPREPLY=($(compgen -W "$_lsreplica_opts" -- $cur));;
+ lssite)
+ COMPREPLY=($(compgen -W "$_lssite_opts" -- $cur));;
+ lsstgloc)
+ _lsstgloc;;
+ lsstream)
+ _lsstream;;
+ lstype)
+ _lstype;;
+ lsview)
+ _lsview;;
+ lsvob)
+ _lsvob;;
+ lsvtree|vtree)
+ COMPREPLY=($(compgen -W "$_lsvtree_opts" -- $cur));;
+ man)
+ COMPREPLY=($(compgen -W "$_scm_cmds" -- $cur));;
+ merge)
+ COMPREPLY=($(compgen -W "$_merge_opts" -- $cur));;
+ mkactivity)
+ _mkactivity;;
+ mkattr)
+ COMPREPLY=($(compgen -W "$_mkattr_opts" -- $cur));;
+ mkattype)
+ COMPREPLY=($(compgen -W "$_mkattype_opts" -- $cur));;
+ mkbl)
+ _mkbl;;
+ mkbranch)
+ COMPREPLY=($(compgen -W "$_mkbranch_opts" -- $cur));;
+ mkbrtype)
+ COMPREPLY=($(compgen -W "$_mkbrtype_opts" -- $cur));;
+ mkcomp)
+ _mkcomp;;
+ mkdir)
+ COMPREPLY=($(compgen -W "$_mkdir_opts" -- $cur));;
+ mkelem)
+ COMPREPLY=($(compgen -W "$_mkelem_opts" -- $cur));;
+ mkeltype)
+ COMPREPLY=($(compgen -W "$_mkeltype_opts" -- $cur));;
+ mkfolder)
+ _mkfolder;;
+ mkhlink)
+ COMPREPLY=($(compgen -W "$_mkhlink_opts" -- $cur));;
+ mkhltype)
+ COMPREPLY=($(compgen -W "$_mkhltype_opts" -- $cur));;
+ mklabel)
+ COMPREPLY=($(compgen -W "$_mklabel_opts" -- $cur));;
+ mklbtype)
+ COMPREPLY=($(compgen -W "$_mklbtype_opts" -- $cur));;
+ mkpool)
+ COMPREPLY=($(compgen -W "$_mkpool_opts" -- $cur));;
+ mkproject)
+ _mkproject;;
+ mkregion)
+ _mkregion;;
+ mkstgloc)
+ _mkstgloc;;
+ mkstream)
+ _mkstream;;
+ mktag)
+ _mktag;;
+ mktrigger)
+ COMPREPLY=($(compgen -W "$_mktrigger_opts" -- $cur));;
+ mktrtype)
+ _mktrtype;;
+ mkview)
+ _mkview;;
+ mkvob)
+ _mkvob;;
+ mount)
+ _mount;;
+ move)
+ COMPREPLY=($(compgen -W "$_move_opts" -- $cur));;
+ protect)
+ COMPREPLY=($(compgen -W "$_protect_opts" -- $cur));;
+ protectvob)
+ COMPREPLY=($(compgen -W "$_protectvob_opts" -- $cur));;
+ pwd)
+ COMPREPLY=($(compgen -W "$_pwd_opts" -- $cur));;
+ pwv)
+ COMPREPLY=($(compgen -W "$_pwv_opts" -- $cur));;
+ rebase)
+ _rebase;;
+ recoverview)
+ _recoverview;;
+ reformatview)
+ _reformatview;;
+ reformatvob)
+ _reformatvob;;
+ register)
+ _register;;
+ relocate)
+ COMPREPLY=($(compgen -W "$_relocate_opts" -- $cur));;
+ rename)
+ COMPREPLY=($(compgen -W "$_rename_opts" -- $cur));;
+ reqmaster)
+ COMPREPLY=($(compgen -W "$_reqmaster_opts" -- $cur));;
+ reserve)
+ COMPREPLY=($(compgen -W "$_reserve_opts" -- $cur));;
+ rmactivity)
+ _rmactivity;;
+ rmattr)
+ _rmattr;;
+ rmbl)
+ _rmbl;;
+ rmbranch)
+ COMPREPLY=($(compgen -W "$_rmbranch_opts" -- $cur));;
+ rmcomp)
+ _rmcomp;;
+ rmdo)
+ COMPREPLY=($(compgen -W "$_rmdo_opts" -- $cur));;
+ rmelem)
+ COMPREPLY=($(compgen -W "$_rmelem_opts" -- $cur));;
+ rmfolder)
+ _rmfolder;;
+ rmhlink)
+ _rmhlink;;
+ rmlabel)
+ _rmlabel;;
+ rmmerge)
+ COMPREPLY=($(compgen -W "$_rmmerge_opts" -- $cur));;
+ rmname)
+ COMPREPLY=($(compgen -W "$_rmname_opts" -- $cur));;
+ rmpool)
+ COMPREPLY=($(compgen -W "$_rmpool_opts" -- $cur));;
+ rmproject)
+ _rmproject;;
+ rmregion)
+ _rmregion;;
+ rmstgloc)
+ _rmstgloc;;
+ rmstream)
+ _rmstream;;
+ rmtag)
+ _rmtag;;
+ rmtrigger)
+ _rmtrigger;;
+ rmtype)
+ _rmtype;;
+ rmver)
+ COMPREPLY=($(compgen -W "$_rmver_opts" -- $cur));;
+ rmview)
+ _rmview;;
+ rmvob)
+ _rmvob;;
+ schedule)
+ COMPREPLY=($(compgen -W "$_schedule_opts" -- $cur));;
+ setcache)
+ COMPREPLY=($(compgen -W "$_setcache_opts" -- $cur));;
+ setcs)
+ _setcs;;
+ setview)
+ _setview;;
+ setplevel)
+ _setplevel;;
+ setsite)
+ COMPREPLY=($(compgen -W "$_setsite_opts" -- $cur));;
+ space)
+ _space;;
+ startview)
+ _startview;;
+ umount)
+ _umount;;
+ uncheckout|unco)
+ COMPREPLY=($(compgen -W "$_uncheckout_opts" -- $cur));;
+ unlock)
+ _unlock;;
+ unregister)
+ COMPREPLY=($(compgen -W "$_unregister_opts" -- $cur));;
+ unreserve)
+ COMPREPLY=($(compgen -W "$_unreserve_opts" -- $cur));;
+ update)
+ COMPREPLY=($(compgen -W "$_update_opts" -- $cur));;
+ winkin)
+ COMPREPLY=($(compgen -W "$_winkin_opts" -- $cur));;
+ esac
+ fi
+ fi
+} # _scm
+
+# TODO: These functions aren't working very well yet.
+function _type_selector () {
+ local cur prev prev2
+
+ cur="${COMP_WORDS[COMP_CWORD]}"
+
+ if (($COMP_CWORD - 1 >= 0)); then
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+ fi
+
+ if (($COMP_CWORD - 2 >= 0)); then
+ prev2="${COMP_WORDS[COMP_CWORD-2]}"
+ fi
+
+ if [[ $prev == : ]]; then
+ COMPREPLY=($(compgen -W "$(ct lstype -kind $prev2 -short -invob $dvob | grep ^$cur)" -- $cur))
+ elif [[ $cur == : ]]; then
+ COMPREPLY=($(compgen -W "$(ct lstype -kind $prev -short -invob $dvob)"))
+ elif [[ $cur == * ]]; then
+ COMPREPLY=($(compgen -W "$_type_selectors" -- $cur))
+ fi
+} # _type_selector
+
+function _object_selector () {
+ local cur prev prev2
+
+ COMPREPLY=()
+
+ cur="${COMP_WORDS[COMP_CWORD]}"
+
+ if (($COMP_CWORD - 1 >= 0)); then
+ prev="${COMP_WORDS[COMP_CWORD-1]}"
+ fi
+
+ if (($COMP_CWORD - 2 >= 0)); then
+ prev2="${COMP_WORDS[COMP_CWORD-2]}"
+ fi
+
+ if [[ $prev == activity || ($prev == : && $prev2 == activity) ]]; then
+ if [[ $cur == : ]]; then
+ COMPREPLY=($(compgen -W "$(_activities)" -- ""))
+ else
+ echo "cur = $cur"
+ COMPREPLY=($(compgen -W "$(_activities $cur)"))
+ echo "COMPREPLY = ${COMPREPLY[*]}"
+ fi
+ elif [[ $prev == lbtype || ($prev == : && $prev2 == lbtype) ]]; then
+ if [[ $cur == : ]]; then
+ COMPREPLY=($(compgen -W "$(_lbtypes)" -- ""))
+ echo "COMPREPLY = ${COMPREPLY[*]}"
+ else
+ echo "cur = $cur"
+ COMPREPLY=($(compgen -W "$(_lbtypes $cur)"))
+ echo "COMPREPLY = ${COMPREPLY[*]}"
+ fi
+ elif [[ $cur == * ]] ; then
+ COMPREPLY=($(compgen -W "$_object_selectors" -- $cur))
+ fi
+} # _object_selector
+
+complete -o default -F _scm scm ct
+
+complete -F _catcs catcs
+complete -F _checkin ci
+complete -F _deliver deliver
+complete -F _endview endview
+complete -F _lsactivity lsact
+complete -F _lsbl lsbl
+complete -F _lsproject lsproj
+complete -F _lsfolder lsfolder llfolder
+complete -F _lsstgloc lsstgloc
+complete -F _lsstream lsstream llstream
+complete -F _lsview lsview llview
+complete -F _lsvob lsvob llvob
+complete -F _merge merge
+complete -F _mktag mktag
+complete -F _mkview mkview
+complete -F _rebase rebase
+complete -F _rmtag rmtag
+complete -F _rmview rmview
+complete -F _setactivity setact
+complete -F _setcs setcs
+complete -F _setview setview
+complete -F _startview startview
+complete -F _space space
+complete -F _register register
+complete -F _uncheckout unco
+complete -F _unregister unregister
+
+complete -F _object_selector -o nospace lstype
+complete -F _object_selector -o nospace lltype
+complete -F _object_selector -o nospace lslock
+complete -F _object_selector -o nospace lllock
--- /dev/null
+# Clearcase configuration: This file is sourced by ~/.rc/clearcase so you
+# can set some variables if you like to represent site defaults
+
+# The vobtag prefix in use at this site
+if [ $ARCH = 'cygwin' ]; then
+ export VOBTAG_PREFIX=\\
+else
+ export VOBTAG_PREFIX=/vob/
+fi
+
+# While for most commands we use $VOBTAG_PREFIX even when in Cygwin because
+# from a command line we are often calling cleartool (through the scm function)
+# We do want the setview function to mount vobs in the Linux way so we export
+# this variable for that purpose.
+export LINUX_VOBTAG_PREFIX=/vob
+
+# The default pvob
+export pvob=${VOBTAG_PREFIX}9200_projects
+
+# The default vob
+export dvob="${VOBTAG_PREFIX}9200"
\ No newline at end of file
--- /dev/null
+################################################################################
+#
+# File: $RCSfile: clearcase_profile,v $
+# Revision: $Revision: 1.2 $
+# Description: Clearcase profile
+# Author: Andrew@ClearSCM.com
+# Created: Fri Jun 27 17:45:37 MST 2008
+# Modified: $Date: 2010/04/27 03:27:21 $
+# Language: .clearcase_profile
+#
+# (c) Copywrite 2000-2009, Andrew@ClearSCM.com, all rights reserved.
+#
+################################################################################
+checkout -nc
+checkin -nc
+mkelem -nc
+unco -rm
--- /dev/null
+#!/bin/bash
+################################################################################
+#
+# File: $RCSfile: Broadcom,v $
+# Revision: $Revision: 1.1 $
+# Description: Client specific start up for Broadcom
+# Author: Andrew@DeFaria.com
+# Created: Wed Jan 18 14:09:31 PST 2012
+# Modified: $Date: 2013/03/26 20:52:09 $
+# Language: bash
+#
+# (c) Copyright 2012, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+append_to_path /projects/mob_tools/scripts
+append_to_path /projects/mob_tools/bin
+append_to_path /tools/ecloud/commander/bin
+append_to_path /usr/brcm/ba/bin
+append_to_path /projects/mob_tools/scripts
+append_to_path /tools/bin
+append_to_path /opt/Perforce
+
+if [ -f "/cygdrive/c/Program Files/Perforce/p4.exe" ]; then
+ append_to_path "/cygdrive/c/Program Files/Perforce"
+elif [ -f "/cygdrive/c/Program Files (x86)/Perforce/p4.exe" ]; then
+ append_to_path "/cygdrive/c/Program Files (x86)/Perforce"
+fi
+
+alias baperl=/usr/brcm/ba/bin/perl
+
+export CDPATH=$CDPATH:/mcsi:/mob_tools
+
+alias repo=/projects/mob_tools/bin/repo
--- /dev/null
+#!/bin/bash
+################################################################################
+#
+# File: $RCSfile: GD,v $
+# Revision: $Revision: 1.1 $
+# Description: Client specific start up for General Dynamics
+# Author: Andrew@DeFaria.com
+# Created: Mon Aug 20 17:35:01 2001
+# Modified: $Date: 2010/04/09 05:36:46 $
+# Language: bash
+#
+# (c) Copyright 2000-2005, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+umask 002
+
+export SITE_PERLLIB=/cleartrig/ent/SNSD/muos/ccadm_tools/vobs/ranccadm/scripts/lib
+export PATH=/cleartrig/ent/SNSD/muos/ccadm_tools/vobs/ranccadm/scripts/clearcase:$PATH
+
+export http_proxy=webgate0.gddsi.com:8080
+export ftp_proxy=webgate0.gddsi.com
+
+export QTDIR="/usr/local/Trolltech/Qt-4.2.2"
+export QMAKESPEC="$QTDIR/mkspecs/solaris-cc"
+export ORACLE="SID rancq"
+export ORACLE_HOME="/usr/local/oracle/product/9.2"
+
+export CCASE_MAKE_COMPAT=gnu
+
+export CQ_HOME=/opt/rational/clearquest
+export CQ_HELP_BROWSER=firefox
+export CQ_PERLLIB=/opt/rational/common/lib/perl5/5.6.1/sun4-solaris-multi:/opt/rational/common/lib/perl5/5.6.1:/opt/rational/common/lib/perl5/site_perl/5.6.1/sun4-solaris-multi:/opt/rational/common/lib/perl5/site_perl/5.6.1:/opt/rational/common/lib/perl5/site_perl
+
+export TZ="US/Arizona"
+
+alias xv=/prj/Synopsis/gccsparcOS5/ccss/utils/xv/xv
+
+export RSU_LICENSE_MAP="/prj/muosran/config/Rational_License_Map"
+
+export LM_LICENSE_FILE="flex2:1850@flex2:15280@ranadm2:19353@ranadm2:19355@ranadm2:2468@ranadm2:1717@flex2:1711@bartlett:1711@flex3:27000@ranadm2:28000@ranadm2:5270@flex2"
+
+alias xemacs="ssh muosbldforge2 xemacs"
+
+export EDITOR="ssh muosbldforge2 xemacs"
+
+if [ $(uname) = "SunOS" ]; then
+ export QTDIR=/usr/local/Trolltech/Qt-4.2.2
+ export ORACLE_HOME="/usr/local/oracle/product/9.2"
+ export CQ_HOME=/opt/rational/clearquest/
+elif [ $(uname) = "Linux" ]; then
+ export QTDIR=/usr/local/Trolltech/Qt-4.2.3
+ export ORACLE_HOME="/usr/local/oracle/product/10.2.0"
+ export LD_LIBRARY_PATH=$LD_LIBRARY_PATH:/usr/X11R6/lib
+fi
\ No newline at end of file
--- /dev/null
+#!/bin/bash
+################################################################################
+#
+# File: $RCSfile: GE,v $
+# Revision: $Revision: 1.1 $
+# Description: Client specific start up for General Electric
+# Author: Andrew@DeFaria.com
+# Created: Mon Aug 20 17:35:01 2001
+# Modified: $Date: 2010/05/31 21:20:53 $
+# Language: bash
+#
+# (c) Copyright 2010, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+export CDPATH="$CDPATH:/vobs/ce_gdn_src:/vobs/scm_tools_src"
--- /dev/null
+# Configuration file for dircolors, a utility to help you set the
+# LS_COLORS environment variable used by GNU ls with the --color option.
+
+# The keywords COLOR, OPTIONS, and EIGHTBIT (honored by the
+# slackware version of dircolors) are recognized but ignored.
+
+# Below, there should be one TERM entry for each termtype that is colorizable
+TERM linux
+TERM linux-c
+TERM mach-color
+TERM console
+TERM con132x25
+TERM con132x30
+TERM con132x43
+TERM con132x60
+TERM con80x25
+TERM con80x28
+TERM con80x30
+TERM con80x43
+TERM con80x50
+TERM con80x60
+TERM dtterm
+TERM xterm
+TERM xterm-color
+TERM xterm-debian
+TERM rxvt
+TERM screen
+TERM screen-w
+TERM vt100
+TERM Eterm
+
+# Below are the color init strings for the basic file types. A color init
+# string consists of one or more of the following numeric codes:
+# Attribute codes:
+# 00=none 01=bold 04=underscore 05=blink 07=reverse 08=concealed
+# Text color codes:
+# 30=black 31=red 32=green 33=yellow 34=blue 35=magenta 36=cyan 37=white
+# Background color codes:
+# 40=black 41=red 42=green 43=yellow 44=blue 45=magenta 46=cyan 47=white
+NORMAL 00 # global default, although everything should be something.
+FILE 00 # normal file
+DIR 01;33 # directory
+LINK 01;36 # symbolic link. (If you set this to 'target' instead of a
+ # numerical value, the color is as for the file pointed to.)
+FIFO 40;33 # pipe
+SOCK 01;35 # socket
+DOOR 01;35 # door
+BLK 40;33;01 # block device driver
+CHR 40;33;01 # character device driver
+ORPHAN 40;31;01 # symlink to nonexistent file
+
+# This is for files with execute permission:
+EXEC 01;32
+
+# List any file extensions like '.gz' or '.tar' that you would like ls
+# to colorize below. Put the extension, a space, and the color init string.
+# (and any comments you want to add after a '#')
+
+# If you use DOS-style suffixes, you may want to uncomment the following:
+#.cmd 01;32 # executables (bright green)
+#.exe 01;32
+#.com 01;32
+#.btm 01;32
+#.bat 01;32
+
+.tar 01;31 # archives or compressed (bright red)
+.tgz 01;31
+.arj 01;31
+.taz 01;31
+.lzh 01;31
+.zip 01;31
+.z 01;31
+.Z 01;31
+.gz 01;31
+.bz2 01;31
+.deb 01;31
+.rpm 01;31
+.jar 01;31
+
+# image formats
+.jpg 01;35
+.jpeg 01;35
+.gif 01;35
+.bmp 01;35
+.pbm 01;35
+.pgm 01;35
+.ppm 01;35
+.tga 01;35
+.xbm 01;35
+.xpm 01;35
+.tif 01;35
+.tiff 01;35
+.png 01;35
+.mov 01;35
+.mpg 01;35
+.mpeg 01;35
+.avi 01;35
+.fli 01;35
+.gl 01;35
+.dl 01;35
+.xcf 01;35
+.xwd 01;35
+
+# audio formats
+.ogg 01;35
+.mp3 01;35
+.wav 01;35
--- /dev/null
+#!/bin/bash
+###############################################################################
+#
+# File: $RCSfile: functions,v $
+# Revision: $Revision: 1.20 $
+# Description: Common bash functions
+# Author: Andrew@DeFaria.com
+# Created: Thu Jun 6 08:31:57 PDT 1996
+# Modified: $Date: 2013/03/26 20:38:23 $
+# Language: bash
+#
+# (c) Copyright 2000-2005, Andrew@DeFaria.com, all rights reserved.
+#
+###############################################################################
+ESC=$(echo "\033")
+CR=$(echo "\015")
+
+view_name=
+
+# Function to set the title bar. Works on the terminal emulators listed.
+function title_bar {
+ prefix="$@"
+ # Change $HOME -> ~
+ if [ "${PWD#$HOME*}" != "$PWD" ]; then
+ current_dir="~${PWD#$HOME*}"
+ elif [ "$PWD" = "$HOME" ]; then
+ current_dir=~
+ else
+ current_dir="$PWD"
+ fi
+
+ # Remove view name
+ current_dir="${current_dir#/view/$view_name*}"
+ current_dir="${current_dir#/sview/$view_name*}"
+
+ # Add CVS/Root if there is one
+ if [ -f "CVS/Root" ]; then
+ current_dir="$current_dir ($(cat CVS/Root | tr -d $CR))"
+ fi
+
+ if [ "$TERM" = "hpterm" -o \
+ "$TERM" = "hp" -o \
+ "$TERM" = "2392A" ]; then
+ string=$(echo "${SYSNAME##*:}:$@")
+ echo -n "${ESC}&f0k${#string}D$string"
+ elif [ "$TERM" = "dtterm" -o \
+ "$TERM" = "vt221" ]; then
+ string=$(echo "${SYSNAME##*:}:$@")
+ echo -n "${ESC}]2;$string\007"
+ elif [ "$TERM" = "cygwin" -o "$TERM" = "vt100" -o "$TERM" = "xterm" ]; then
+ PS1="\[\e]0;$prefix$current_dir\a\e[01;33m\]$SYSNAME:\[\e[0m\]"
+ fi
+} # title_bar
+
+# Function to set the icon name. Works on the terminal emulators listed.
+function icon_name {
+ if [ "$TERM" = "hpterm" -o \
+ "$TERM" = "hp" -o \
+ "$TERM" = "2392A" ]; then
+ string=$(echo "$1")
+ echo -n "${ESC}&f-1k${#string}D$string"
+ elif [ "$TERM" = "dtterm" -o \
+ "$TERM" = "vt100" -a "$DTTERM" = "True" ]; then
+ # Note setting icon_name on vt100 overwrites the title bar so skip it
+ echo -n "${ESC}]1;$@\007"
+ fi
+} # icon_name
+
+# Sets both the title bar and the icon name.
+function title {
+ title_bar "$@"
+ icon_name "${SYSNAME##*:}"
+} # title
+
+# Sets title bar to machine name and path. Will include a view name if in a
+# view and a string to indicate that you are root.
+function set_title {
+ if [ $($id -u) -eq 0 ]; then
+ ROOT="Wizard "
+ else
+ ROOT=
+ fi
+
+ view_name=$(scm pwv -short 2> /dev/null);
+
+ if [ $? -ne 0 -o -z "$view_name" ]; then
+ view_name='*NONE*'
+ fi
+
+ if [[ $view_name = *NONE* ]]; then
+ view_name=""
+ title_bar "$ROOT"
+ else
+ title_bar "${ROOT}View: $view_name: "
+ fi
+
+ icon_name "${SYSNAME##*:}"
+} # set_title
+
+# Sets prompt on terminals listed.
+function set_prompt {
+ if [ $($id -u) -eq 0 ]; then
+ if [ "$TERM" = "hpterm" -o \
+ "$TERM" = "hp" -o \
+ "$TERM" = "2392A" -o \
+ "$TERM" = "dtterm" -o \
+ ! -z "$DTTERM" ]; then
+ ROOT="${RED}Wizard$NORMAL "
+ elif [ "$TERM" = "vt100" -o \
+ "$TERM" = "xterm" -o \
+ "$TERM" = "vt220" ]; then
+ ROOT="${BOLD}${BLINK}Wizard$NORMAL "
+ fi
+ else
+ ROOT=""
+ fi
+
+ if [ "$TERM" = "vt100" -o \
+ "$TERM" = "xterm" -o \
+ "$TERM" = "vt220" ]; then
+ PS1="$ROOT$BOLD$SYSNAME:$NORMAL"
+ else
+ PS1="$ROOT$SYSNAME:"
+ fi
+
+ set_title
+} # set_prompt
+
+# Function to override the normal cd command, setting title and prompt.
+function mycd {
+ if [ -z "$1" ]; then
+ \cd ~
+ else
+ \cd "$1"
+ fi
+ set_title
+ set_prompt
+} # mycd
+export mycd
+
+# Functions to override the normal push/popd commands, setting title and prompt.
+function mypushd {
+ if [ -z "$1" ]; then
+ \pushd > /dev/null
+ else
+ \pushd "$1" > /dev/null
+ fi
+ set_title
+ set_prompt
+} # mypushd
+
+function mypopd {
+ if [ -z "$1" ]; then
+ cd - > /dev/null
+ else
+ \popd "$1" > /dev/null
+ fi
+ set_title
+ set_prompt
+} # mypopd
+
+# Function to override rlogin. Note that it fixes up the title and prompt
+# upon return.
+function rlogin {
+ /usr/bin/rlogin "$@"
+ set_title
+ set_prompt
+} # rlogin
+
+# Function to override rsh. Note that it fixes up the title and prompt
+# upon return.
+function rsh {
+ /usr/bin/rsh "$@"
+ set_title
+ set_prompt
+} # rsh
+
+# Function to override ssh. Note that it fixes up the title and prompt
+# upon return.
+function ssh {
+ /usr/bin/ssh "$@"
+ set_title
+ set_prompt
+} # ssh
+
+function sj {
+ if [ $ARCH = "FreeBSD" ]; then
+ psopts="-aux"
+ else
+ psopts="-ef"
+ fi
+
+ if [ $# = 0 ]; then
+ ps $psopts | $PAGER
+ else
+ for str; do
+ ps $psopts | grep "$str" | grep -v "grep $str" | grep -v "grep -d skip"
+ done
+ fi
+} # sj
+
+function start_imap {
+ # Starts an ssh tunnel for IMAP
+ ssh -C -L 143:defaria.com:143 andrew@defaria.com
+} # start_imap
+
+function cmdline {
+ # Displays the command line from the /proc filesystem (if present)
+
+ me=$0;
+
+ if [ $# -ne 1 ]; then
+ error "Usage: cmdline <pid>"
+ return 1
+ fi
+
+ pid=$1;
+
+ if [ ! -d "/proc" ]; then
+ error "This OS has no /proc filesystem"
+ return 1
+ fi
+
+ if [ ! -d "/proc/$pid" ]; then
+ error "PID $pid does not exist"
+ return 1
+ fi
+
+ if [ ! -f "/proc/$pid/cmdline" ]; then
+ error "PID $pid has no cmdline!"
+ return 1
+ fi
+
+ cat /proc/$pid/cmdline | tr -c [:print:] " "
+ display
+} # cmdline
+
+function user {
+ if [ $# -gt 0 ]; then
+ ypcat passwd | grep -i $@
+ else
+ ypcat passwd | $PAGER
+ fi
+} # user
+
+function group {
+ if [ $# -gt 0 ]; then
+ ypcat group | grep -i $@
+ else
+ ypcat group | $PAGER
+ fi
+} # group
--- /dev/null
+# .inputrc is used by GNU's readline routine
+#
+# This tells filename completion to be case insensitive
+set completion-ignore-case on
+
+# Home
+"\e[7~": beginning-of-line
+"\e[h~": beginning-of-line
+
+# End
+"\e[8~": end-of-line
+
+# Delete
+"\e[3~": delete-char
+
+# Insert
+"\e[2~": paste-from-clipboard
+
+# Control left
+"\eOd": backward-word
+"\e[1;5D": backward-word
+
+# Control right
+"\eOc": forward-word
+"\e[1;5C": forward-word
+
+# Function keys (From Randhuall R Schulz <rrschulz@cris.com>)
+# F1 - F5 (Console)
+"\M-[[A" "F1"
+"\M-[[B" "F2"
+"\M-[[C" "2>&1 &"
+"\M-[[D" "F4"
+"\M-[[E" "F5"
+
+# F1 - F3 (RXVT)
+"\M-[11~" "F1"
+"\M-[12~" "F2"
+"\M-[13~" "2>&1 &"
+"\M-[14~" "F4"
+"\M-[15~" "F5"
+
+# Both Console and RXVT
+"\M-[17~" "F6"
+"\M-[18~" "F7"
+"\M-[19~" "exit\C-M"
+"\M-[20~" "F9"
+"\M-[21~" "F10"
+"\M-[23~" "F11"
+"\M-[24~" "F12"
+
+# Horizontal scroll...
+#set horizontal-scroll-mode on
+
+# The following tells bash to show all filenames if ambiguous instead of
+# beeping first
+#set show-all-if-ambiguous on
--- /dev/null
+#/usr/bin/env bash
+################################################################################
+#
+# File: $RCSfile: logout,v $
+# Revision: $Revision: 1.4 $
+# Description: Script to run at logout
+# Author: Andrew@DeFaria.com
+# Created: Thu Jun 6 08:31:57 PDT 1996
+# Modified: $Date: 2006/07/24 05:37:40 $
+# Language: bash
+#
+# (c) Copyright 2000-2005, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+if [ -x "$(type -p fortune)" ]; then
+ fortune -sw
+fi
--- /dev/null
+#!/bin/bash
+################################################################################
+#
+# File: $RCSfile: multisite,v $
+# Revision: $Revision: 1.6 $
+# Description: This script set up some useful environment variables and aliases
+# for MultiSite execution. File should be sourced (e.g .
+# multisite)
+# Author: Andrew@DeFaria.com
+# Created: Wed Jun 5 21:08:03 PDT 1996
+# Modified: $Date: 2011/03/07 22:11:23 $
+# Language: bash
+#
+# (c) Copyright 2000-2005, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+if [ $ARCH = "cygwin" ]; then
+ export MSHOME=$(cygpath -u "$(regtool get '/machine/SOFTWARE/Rational Software/RSINSTALLDIR' 2>/dev/null)" 2>/dev/null)
+else
+ export MSHOME=/opt/rational/clearcase/
+fi
+
+if [ ! -d "$MSHOME" ]; then
+ unset MSHOME
+ return
+fi
+
+export MULTITOOL="${MSHOME}bin/multitool"
+
+if [ -x "$MULTITOOL" ]; then
+ export CLEARCASE_BLD_HOST_TYPE=Windows
+ export SLOGS=$LOGS/sync_logs
+
+ if [ $ARCH = "cygwin" ]; then
+ export SB="${MSHOME}var/shipping/ms_ship"
+ else
+ export SB="/var/adm/rational/clearcase/shipping/ms_ship"
+ fi
+fi
+
+function mt {
+ if [ -x "$MULTITOOL" ]; then
+ "$MULTITOOL" "$@"
+ else
+ echo "MultiSite is not installed on this system!"
+ fi
+} # mt
+
+function lspacket {
+ "$MULTITOOL" lspacket "$@"
+} # lspacket
+
+function llpacket {
+ "$MULTITOOL" lspacket -long "$@"
+} # llpacket
+
+function lsreplica {
+ "$MULTITOOL" lsreplica -invob "$@"
+} # lsreplica
+
+function llreplica {
+ "$MULTITOOL" lsreplica -long -invob "$@"
+} # llreplica
+
+function lsepoch {
+ "$MULTITOOL" lsepoch -invob "$@"
+} # lsepoch
+
+function llepoch {
+ "$MULTITOOL" lsepoch -long -invob "$@"
+} # llepoch
+
+function chepoch {
+ "$MULTITOOL" chepoch -invob "$@"
+} # chepoch
+
+function shipping_server {
+ $MSHOME/etc/shipping_server "$@"
+} # shipping_server
+
+function mkorder {
+ $MSHOME/etc/mkorder "$@"
+} # mkorder
+
+function syncreplica {
+ "$MULTITOOL" syncreplica "$@"
+} # syncreplica
--- /dev/null
+################################################################################
+#
+# File: $RCSfile: perlcriticrc,v $
+# Revision: $Revision: 1.3 $
+# Description: Perlcritic defaults
+# Author: Andrew@DeFaria.com
+# Created: Fri Jan 23 11:08:55 MST 2009
+# Modified: $Date: 2011/01/09 01:04:56 $
+# Language: perltidy
+#
+# (c) Copyright 2000-2009, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+severity = harsh
+
+# We think these are really important, so always load them
+[TestingAndDebugging::RequireUseStrict]
+severity = 5
+
+[TestingAndDebugging::RequireUseWarnings]
+severity = 5
+
+# We like function prototypes
+[-Subroutines::ProhibitSubroutinePrototypes]
+
+# Not every regex needs to be fully explained
+[RegularExpressions::RequireExtendedFormatting]
+minimum_regex_length_to_complain_about = 20
+
+# Backticks only in non void contexts
+[InputOutput::ProhibitBacktickOperators]
+only_in_void_context = 1
+
+# Reading from STDIN should be OK
+[-InputOutput::ProhibitExplicitStdin]
+
+# Cascading elsif's are not that difficult to understand. Switch is not
+# that much easier. And switch is not available without a CPAN module install
+# which is not always available
+[ControlStructures::ProhibitCascadingIfElse]
+max_elsif = 99
+
+# In multipocess situations you don't want to localize %SIG or you can get
+# defunct children.
+[Variables::RequireLocalizedPunctuationVars]
+allow = %SIG
+
+# Actually I find reading regex's is not that hard. Perl programmers should be
+# able to do it. Besides it's not the character count that makes a regex
+# complicated - it's more it's complication than the number of characters.
+[RegularExpressions::RequireExtendedFormatting]
+minimum_regex_length_to_complain_about = 50
\ No newline at end of file
--- /dev/null
+parse_options ('windowSize=20');
+parse_options ('HistFile=.perldb.hist');
--- /dev/null
+################################################################################
+#
+# File: $RCSfile: perltidyrc,v $
+# Revision: $Revision: 1.1 $
+# Description: Perltidy defaults
+# Author: Andrew@DeFaria.com
+# Created: Fri Jan 23 11:08:55 MST 2009
+# Modified: $Date: 2010/04/09 05:40:01 $
+# Language: perltidy
+#
+# (c) Copyright 2000-2009, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+--indent-columns=2
+--output-line-ending=unix
+--noline-up-parentheses
+--nooutdent-labels
+--paren-tightness=2
+--square-bracket-tightness=2
+--brace-tightness=2
+--block-brace-tightness=2
+--nospace-for-semicolon
+--space-keyword-paren
+--space-function-paren
+--closing-side-comments
+--cuddled-else
+--opening-token-right
+--stack-opening-tokens
--- /dev/null
+#!/bin/bash
+################################################################################
+#
+# File: $RCSfile: set_colors,v $
+# Revision: $Revision: 1.3 $
+# Description: Set color variables
+# Author: Andrew@DeFaria.com
+# Created: Thu Jun 6 08:31:57 PDT 1996
+# Modified: $Date: 2010/04/12 15:57:33 $
+# Language: bash
+#
+# (c) Copyright 2000-2005, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+export esc=$(echo "\033")
+
+if [ "$TERM" = "vt100" -o \
+ "$TERM" = "vt220" ]; then
+ export NORMAL="$esc[0m"
+ export BOLD="$esc[1m"
+ export UNDERLINE="$esc[4m"
+ export BLINK="$esc[5m"
+ export INVERSE="$esc[7m"
+elif [ "$TERM" = "dtterm" -o "$TERM" = "vt100" -o "$TERM" = "xterm" -o -z DTTERM ]; then
+ export NORMAL="$esc[39m"
+ export RED="$esc[31m"
+ export B_RED=$RED
+ export GREEN="$esc[32m"
+ export B_GREEN=$GREEN
+ export YELLOW="$esc[33m"
+ export B_YELLOW=$YELLOW
+ export BLUE="$esc[34m"
+ export B_BLUE=$BLUE
+ export MAGENTA="$esc[35m"
+ export B_MAGENTA=$MAGENTA
+ export AQUA="$esc[36m"
+ export B_AQUA=$AQUA
+ export WHITE="$esc[36m"
+ export B_WHITE=$WHITE
+elif [ "$TERM" = "hp" -o "$TERM" = "hpterm" ]; then
+ export NORMAL="$esc&d@$esc&v0S"
+ export RED="$esc&v1S"
+ export GREEN="$esc&v2S"
+ export YELLOW="$esc&v3S"
+ export BLUE="$esc&v4S"
+ export PURPLE="$esc&v5S"
+ export AQUA="$esc&v6S"
+ export HB_NORMAL="$esc&v0S$esc&dK"
+ export B_NORMAL="$esc&v0S$esc&dB"
+ export HB_RED="$esc&v1S$esc&dK"
+ export B_RED="$esc&v1S$esc&dB"
+ export HB_GREEN="$esc&v2S$esc&dK"
+ export B_GREEN="$esc&v2S$esc&dB"
+ export HB_YELLOW="$esc&v3S$esc&dK"
+ export B_YELLOW="$esc&v3S$esc&dB"
+ export HB_BLUE="$esc&v4S$esc&dK"
+ export B_BLUE="$esc&v4S$esc&dB"
+ export PURPLE="$esc&v5S"
+ export HB_PURPLE="$esc&v5S$esc&dK"
+ export B_PURPLE="$esc&v5S$esc&dB"
+ export HB_AQUA="$esc&v6S$esc&dK"
+ export B_AQUA="$esc&v6S$esc&dB"
+ export INVERSE="$esc&v7S"
+ export HB_INVERSE="$esc&v7S$esc&dK"
+ export B_INVERSE="$esc&v7S$esc&dB"
+fi
--- /dev/null
+#!/bin/bash
+################################################################################
+#
+# File: $RCSfile: set_path,v $
+# Revision: $Revision: 1.8 $
+# Description: Sets the path from scratch
+# Author: Andrew@DeFaria.com
+# Created: Thu Jun 6 08:31:57 PDT 1996
+# Modified: $Date: 2012/09/20 18:10:28 $
+# Language: bash
+#
+# (c) Copyright 2000-2005, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+function append_to_path {
+ component="$1"
+
+ if [ -d "$component" ]; then
+ if [ -z "$PATH" ]; then
+ PATH="$component"
+ else
+ PATH="$PATH:$component"
+ fi
+ fi
+} # append_to_path
+
+function append_to_manpath {
+ component="$1"
+
+ if [ -d "$component" ]; then
+ if [ -z "$MANPATH" ]; then
+ MANPATH="$component"
+ else
+ MANPATH="$MANPATH:$component"
+ fi
+ fi
+} # append_to_manpath
+
+if [ -x /app/manpath ]; then
+ OLDIFS=$IFS
+ IFS=:
+ for manpath in $(/app/manpath); do
+ manpath_dirs="$manpath_dirs $manpath"
+ done
+ IFS=$OLDIFS
+fi
+
+# Set up PATH
+path_dirs=
+
+if [ -f /etc/PATH ]; then
+ OLDIFS=$IFS
+ IFS=:
+ for path in $(cat /etc/PATH); do
+ path_dirs="$path_dirs $path"
+ done
+ IFS=$OLDIFS
+fi
+
+if [ "$SYSTEMROOT" ]; then
+ systemroot=$(cygpath -u $SYSTEMROOT)
+fi
+
+path_dirs="$path_dirs\
+ .\
+ "$HOME/bin"\
+ $adm_base/bin\
+ $adm_base/cc\
+ $adm_base/cq\
+ $adm_base/cvsbin\
+ /opt/Rational/Clearcase/bin\
+ /opt/Rational/ClearQuest\
+ /opt/Rational/Common\
+ /bin\
+ /sbin\
+ /usr/local/mysql/bin\
+ /usr/local/maps/bin\
+ /usr/afsws/bin\
+ /usr/afsws\
+ /usr/bin\
+ /usr/X11R6/bin\
+ /usr/bin/X11\
+ /usr/local/ddts/bin\
+ /usr/local/bin\
+ /usr/dt/bin\
+ /usr/openwin/bin\
+ /opt/rational/clearcase/bin\
+ /opt/ibm/rationalsdlc/clearcase/bin\
+ /opt/ibm/rationalsdlc/clearcase/etc\
+ /opt/ibm/rationalsdlc/clearquest/bin\
+ /opt/ibm/rationalsdlc/clearquest\
+ /opt/ibm/rationalsdlc/common\
+ /usr/sbin\
+ /usr/ccs/bin\
+ /usr/seos/bin\
+ /usr/ucb\
+ /opt/ssh/bin\
+ /tools/bin\
+ $systemroot/System32\
+ $systemroot\
+"
+
+manpath_dirs="\
+ /usr/share/man\
+ /usr/dt/man\
+ /usr/dt/man/man1\
+ /usr/cns/man\
+ /usr/local/packages/ccperl/ccperl5.001m/man\
+ /usr/local/packages/atria/current/man\
+ /usr/local/packages/emacs/man\
+ /usr/seos/man\
+ /opt/ssh/man\
+ /opt/medusa/share/man\
+ /usr/afsws/man\
+"
+
+PATH=
+for component in $path_dirs; do
+ append_to_path "$component"
+done
+
+# Set up MANPATH
+if [ -f /etc/MANPATH ]; then
+ MANPATH=$(cat /etc/MANPATH)
+fi
+
+for component in $manpath_dirs; do
+ append_to_manpath "$component"
+done
+
+# Set up SHLIB_PATH
+if [ "hp-ux" = "10" ]; then
+ export SHLIB_PATH=$(cat /etc/SHLIB_PATH)
+ export SHLIB_PATH=$SHLIB_PATH:$M_LROOT/bin
+ export LD_LIBRARY_PATH=$SHLIB_PATH:$M_LROOT/bin
+fi
+
--- /dev/null
+#!/bin/bash
+################################################################################
+#
+# File: $RCSfile: setup_rc,v $
+# Revision: $Revision: 1.6 $
+# Description: This script sets up my rc scripts
+# Author: Andrew@DeFaria.com
+# Created: Thu Feb 16 07:34:32 PST 2006
+# Modified: $Date: 2011/12/14 22:28:59 $
+# Language: bash
+#
+# (c) Copyright 2006, Andrew@DeFaria.com, all rights reserved
+#
+################################################################################
+function ReplaceFile {
+ dest=$1
+ source=$2
+
+ if [ -f "$dest" ]; then
+ if [ -h "$dest" ]; then
+ return
+ else
+ echo "Saving your old $dest as $dest.save..."
+ mv "$dest" "$dest.save"
+ fi
+ fi
+
+ if [ ! -h "$dest" ]; then
+ ln -s "$source" "$dest"
+ fi
+} # ReplaceFile
+
+function ReplaceDir {
+ dest=$1
+ source=$2
+
+ if [ -d "$dest" ]; then
+ if [ -h "$dest" ]; then
+ return
+ else
+ echo "Saving your old $dest as $dest.save..."
+ mv "$dest" "$dest.save"
+ fi
+ fi
+
+ if [ ! -h "$dest" ]; then
+ ln -s "$source" "$dest"
+ fi
+} # ReplaceDir
+
+if [ ! -d $HOME/.rc ]; then
+ echo "No $HOME/.rc directory found"
+ exit 1
+fi
+
+ReplaceFile "$HOME/.Xdefaults" "$HOME/.rc/Xdefaults"
+ReplaceFile "$HOME/.bash_login" "$HOME/.rc/bash_login"
+ReplaceFile "$HOME/.bashrc" "$HOME/.rc/bash_login"
+ReplaceFile "$HOME/.inputrc" "$HOME/.rc/inputrc"
+ReplaceFile "$HOME/.vimrc" "$HOME/.rc/vimrc"
+ReplaceDir "$HOME/.xemacs" "$HOME/.rc/xemacs"
+ReplaceFile "$HOME/.ssh/config" "$HOME/.rc/sshconfig"
+ReplaceFile "$HOME/.perlcriticrc" "$HOME/.rc/perlcriticrc"
+ReplaceFile "$HOME/.perltidyrc" "$HOME/.rc/perltidyrc"
--- /dev/null
+<big><strong><a href="http://defaria.com">Andrew DeFaria</a></strong></big>
+$
+<small><font color="#999999">11th commandment - Covet not thy neighbor's Pentium.</font></small>
+%
+<small><font color="#999999">2 + 2 = 5 for extremely large values of 2.</font></small>
+%
+<small><font color="#999999">2400 Baud makes you want to get out and push!!</font></small>
+%
+<small><font color="#999999">24 hours in a day...24 beers in a case...coincidence?</font></small>
+%
+<small><font color="#999999">3 kinds of people: those who can count & those who can't.</font></small>
+%
+<small><font color="#999999">42.7 percent of all statistics are made up on the spot.</font></small>
+%
+<small><font color="#999999">5 days a week my body is a temple. The other two, it's an amusement park.</font></small>
+%
+<small><font color="#999999">"640K ought to be enough for anybody." - Bill Gates, 1981</font></small>
+%
+<small><font color="#999999">640K ought to be enough RAM for anybody. - Bill Gates, 1981</font></small>
+%
+<small><font color="#999999">99 percent of lawyers give the rest a bad name.</font></small>
+%
+<small><font color="#999999">A balanced diet is a cookie in each hand.</font></small>
+%
+<small><font color="#999999">A bartender is just a pharmacist with a limited inventory.</font></small>
+%
+<small><font color="#999999">A bird in the hand makes it difficult to blow your nose.</font></small>
+%
+<small><font color="#999999">(A)bort, (R)etry, (G)et a beer?</font></small>
+%
+<small><font color="#999999">(A)bort, (R)etry, (T)ake down entire network?</font></small>
+%
+<small><font color="#999999">A budget is just a method of worrying before you spend money, as well as afterward.</font></small>
+%
+<small><font color="#999999">A bus station is where a bus stops. A train station is where a train stops. On my desk, I have a work station... Go figure!</font></small>
+%
+<small><font color="#999999">Access denied--nah nah na nah nah!</font></small>
+%
+<small><font color="#999999">A Clean House Is A Sign Of A Misspent Life</font></small>
+%
+<small><font color="#999999">A clear conscience is usually the sign of a bad memory.</font></small>
+%
+<small><font color="#999999">A closed mouth gathers no feet.</font></small>
+%
+<small><font color="#999999">A common mistake people make when trying to design something completely foolproof is to underestimate the ingenuity of complete fools. - Douglas Adams</font></small>
+%
+<small><font color="#999999">A computer's attention span is as long as it's power cord.</font></small>
+%
+<small><font color="#999999">A conclusion is simply the place where you got tired of thinking.</font></small>
+%
+<small><font color="#999999">A conscience is what hurts when all your other parts feel so good.</font></small>
+%
+<small><font color="#999999">A cubicle is just a padded cell without a door.</font></small>
+%
+<small><font color="#999999">A day without sunshine is like night.</font></small>
+%
+<small><font color="#999999">Adults are just kids who owe money.</font></small>
+%
+<small><font color="#999999">Advice - Do not use a hatchet to remove a fly from your forehead.</font></small>
+%
+<small><font color="#999999">A dyslexic man walks into a bra...</font></small>
+%
+<small><font color="#999999">A flashlight is a case for holding dead batteries.</font></small>
+%
+<small><font color="#999999">A fool and his money are soon partying.</font></small>
+%
+<small><font color="#999999">A fool-proof method for sculpting an elephant: First, get a huge block of marble; then chip away everything that doesn't look like an elephant.</font></small>
+%
+<small><font color="#999999">A friend of mine is into Voodoo Acupuncture. You don't have to go. You'll just be walking down the street, and...........ooooohhhhhh, that's much better...</font></small>
+%
+<small><font color="#999999">After eating, do amphibians have to wait one hour before getting out of the water?</font></small>
+%
+<small><font color="#999999">A good friend will come and bail you out of jail but a true friend will be sitting next to you saying, "Dang, that was fun."</font></small>
+%
+<small><font color="#999999">A good scapegoat is almost as good as a solution.</font></small>
+%
+<small><font color="#999999">A husband is someone who takes out the trash and gives the impression he just cleaned the whole house.</font></small>
+%
+<small><font color="#999999">A lady came up to me on the street, pointed at my suede jacket and said, "Don't you know a cow was murdered for that jacket?" I said "I didn't know there were any witnesses. Now I'll have to kill you too."</font></small>
+%
+<small><font color="#999999">Alcohol and calculus don't mix. Never drink and derive.</font></small>
+%
+<small><font color="#999999">All computers wait at the same speed.</font></small>
+%
+<small><font color="#999999">All generalizations are false</font></small>
+%
+<small><font color="#999999">All I ask is a chance to prove that money can't make me happy.</font></small>
+%
+<small><font color="#999999">All I ask is that you treat me no differently than you would the King.</font></small>
+%
+<small><font color="#999999">All I want in life is a warm bed, and unlimited power.</font></small>
+%
+<small><font color="#999999">All of us could take a lesson from the weather. It pays no attention to criticism.</font></small>
+%
+<small><font color="#999999">All that glitters has a high refractive index.</font></small>
+%
+<small><font color="#999999">All things being equal, fat people use more soap.</font></small>
+%
+<small><font color="#999999">All those who believe in psychokinesis raise my hand.</font></small>
+%
+<small><font color="#999999">All wiyht. Rho sritched mg kegtops awound?</font></small>
+%
+<small><font color="#999999">Always borrow money from pessimists. They don't expect to be paid back.</font></small>
+%
+<small><font color="#999999">Always proofread carefully to see if you any words out.</font></small>
+%
+<small><font color="#999999">Always remember to pillage BEFORE you burn.</font></small>
+%
+<small><font color="#999999">Always remember you're unique, just like everyone else.</font></small>
+%
+<small><font color="#999999">Always try to be modest. And be damn proud of it!</font></small>
+%
+<small><font color="#999999">A mainframe: The biggest PC peripheral available.</font></small>
+%
+<small><font color="#999999">Ambition is a poor excuse for not having enough sense to be lazy.</font></small>
+%
+<small><font color="#999999">Ambition is the last refuge of a failure.</font></small>
+%
+<small><font color="#999999">Ambivalent? Well, yes and no.</font></small>
+%
+<small><font color="#999999">A Messy Kitchen Is A Happy Kitchen And This Kitchen Is Delirious</font></small>
+%
+<small><font color="#999999">A musicologist is a man who can read music but can't hear it. - Sir Thomas Beecham (1879 - 1961)</font></small>
+%
+<small><font color="#999999">Analyzing humor is like dissecting a frog. Few people are interested and the frog dies of it. - E. B. White</font></small>
+%
+<small><font color="#999999">An American is a person who isn't afraid to criticize the President but is always polite to traffic cops.</font></small>
+%
+<small><font color="#999999">And don't start a sentence with a conjunction.</font></small>
+%
+<small><font color="#999999">And when I get real, real bored, I like to drive downtown and get a great parking spot, then sit in my car and count how many people ask me if I'm leaving.</font></small>
+%
+<small><font color="#999999">And whose cruel idea was it to put an S in the word Lisp?</font></small>
+%
+<small><font color="#999999">An error? Impossible! My modem is error correcting.</font></small>
+%
+<small><font color="#999999">Animal testing is a bad idea - they get nervous and give the wrong answers.</font></small>
+%
+<small><font color="#999999">An ounce of practice is worth more than tons of preaching. - Mohandas Gandhi</font></small>
+%
+<small><font color="#999999">An oyster is a fish built like a nut.</font></small>
+%
+<small><font color="#999999">Any clod can have the facts, but having opinions is an art. - Charles McCabe</font></small>
+%
+<small><font color="#999999">Anything worth fighting for is worth fighting dirty for.</font></small>
+%
+<small><font color="#999999">A PBS mind in an MTV world.</font></small>
+%
+<small><font color="#999999">A penny saved is ridiculous.</font></small>
+%
+<small><font color="#999999">A preposition must never be used to end a sentence with.</font></small>
+%
+<small><font color="#999999">Are the kids on the Barney Show just too damn happy?</font></small>
+%
+<small><font color="#999999">Are there seeing eye humans for blind dogs?</font></small>
+%
+<small><font color="#999999">Artificial intelligence is no match for natural stupidity</font></small>
+%
+<small><font color="#999999">As a computer, I find your faith in technology amusing.</font></small>
+%
+<small><font color="#999999">ASCII stupid question, get a stupid ANSI!</font></small>
+%
+<small><font color="#999999">A shark is the only fish that can blink with both eyes.</font></small>
+%
+<small><font color="#999999">As I always say "I never repeat myself"</font></small>
+%
+<small><font color="#999999">A singles bar is a place people go to in hopes of meeting the sort of person who wouldn't be caught dead in a singles bar.</font></small>
+%
+<small><font color="#999999">Ask not for whom the bell tolls. Let the machine get it.</font></small>
+%
+<small><font color="#999999">Ask people why they have deer heads on their walls and they tell you it's because they're such beautiful animals.I think my wife is beautiful, but I only have photographs of her on the wall.</font></small>
+%
+<small><font color="#999999">As long as there are tests, there will be prayer in public schools.</font></small>
+%
+<small><font color="#999999">A synonym is a word you use when you can't spell the word you first thought of. - Burt Bacharach</font></small>
+%
+<small><font color="#999999">Atheism is a non-prophet organization.</font></small>
+%
+<small><font color="#999999">A truly wise man never plays leapfrog with a unicorn.</font></small>
+%
+<small><font color="#999999">Avoid unnecessary, unessential and needless repetition and redundancy.</font></small>
+%
+<small><font color="#999999">A waist is a terrible thing to mind.</font></small>
+%
+<small><font color="#999999">Back off man. I'm a scientist.</font></small>
+%
+<small><font color="#999999">Backup not found: (A)bort (R)etry (P)anic</font></small>
+%
+<small><font color="#999999">Backups? Backups? We don't need no stinking backups!</font></small>
+%
+<small><font color="#999999">Bad breath is better than no breath.</font></small>
+%
+<small><font color="#999999">Bad command. Bad, bad command! Sit! Stay! Staaay..</font></small>
+%
+<small><font color="#999999">Beauty is in the eye of the beer holder.</font></small>
+%
+<small><font color="#999999">Be different. Conform.</font></small>
+%
+<small><font color="#999999">Beer: It's not just for breakfast anymore.</font></small>
+%
+<small><font color="#999999">Be nice to your kids. They'll choose your nursing home.</font></small>
+%
+<small><font color="#999999">Better living through denial.</font></small>
+%
+<small><font color="#999999">Better to understand a little than to misunderstand a lot.</font></small>
+%
+<small><font color="#999999">Black holes really suck.</font></small>
+%
+<small><font color="#999999">Borrow money from pessimists-they don't expect it back.</font></small>
+%
+<small><font color="#999999">BREAKFAST.COM Halted...Cereal Port Not Responding</font></small>
+%
+<small><font color="#999999">Budget: A method for going broke methodically.</font></small>
+%
+<small><font color="#999999">BUFFERS=20 FILES=15 2nd down, 4th quarter, 5 yards to go!</font></small>
+%
+<small><font color="#999999">Bureaucracy: a method of turning energy into solid waste</font></small>
+%
+<small><font color="#999999">Buy a Pentium 586/90 so you can reboot faster.</font></small>
+%
+<small><font color="#999999">By the time you make ends meet, they move the ends.</font></small>
+%
+<small><font color="#999999">By the turn of this century, we will live in a paperless society. - Roger Smith, chairman of General Motors, 1986</font></small>
+%
+<small><font color="#999999">Cannot find REALITY.SYS. Universe halted.</font></small>
+%
+<small><font color="#999999">Can vegetarians eat animal crackers?</font></small>
+%
+<small><font color="#999999">Can you be a closet claustrophobic?</font></small>
+%
+<small><font color="#999999">Can you buy anything specific at a general store?</font></small>
+%
+<small><font color="#999999">Can you sentence a homeless man to house arrest?</font></small>
+%
+<small><font color="#999999">Car service: If it ain't broke, we'll break it.</font></small>
+%
+<small><font color="#999999">C:\> Bad command or file name! Go stand in the corner.</font></small>
+%
+<small><font color="#999999">C:\DOS C:\DOS\RUN RUN\DOS\RUN</font></small>
+%
+<small><font color="#999999">Change is inevitable, except from a vending machine.</font></small>
+%
+<small><font color="#999999">Chaos, panic, & disorder -- my work here is done.</font></small>
+%
+<small><font color="#999999">Clones are people two.</font></small>
+%
+<small><font color="#999999">Clothes make the man. Naked people have little or no influence on society. - Mark Twain</font></small>
+%
+<small><font color="#999999">COFFEE.EXE Missing - Insert Cup and Press Any Key</font></small>
+%
+<small><font color="#999999">Collaboration, n.: A literary partnership based on the false assumption that the other person can spell.</font></small>
+%
+<small><font color="#999999">Computers are not intelligent. They only think they are.</font></small>
+%
+<small><font color="#999999">Computers are useless. They can only give you answers. - Pablo Picasso</font></small>
+%
+<small><font color="#999999">Computers make very fast, very accurate mistakes.</font></small>
+%
+<small><font color="#999999">Confidence is the feeling you have before you really understand the problem.</font></small>
+%
+<small><font color="#999999">CONGRESS.SYS Corrupted: Re-boot Washington D.C (Y/n)?</font></small>
+%
+<small><font color="#999999">Consciousness: That annoying time between naps.</font></small>
+%
+<small><font color="#999999">Consider, the Bible was written by the same people who said the Earth was flat.</font></small>
+%
+<small><font color="#999999">Copywight 1994 Elmer Fudd. All wights wesewved.</font></small>
+%
+<small><font color="#999999">C program run. C program crash. C programmer quit.</font></small>
+%
+<small><font color="#999999">"Criminal Lawyer" is a redundancy.</font></small>
+%
+<small><font color="#999999">C:\WINDOWS C:\WINDOWS\GO C:\PC\CRAWL</font></small>
+%
+<small><font color="#999999">Daddy, why doesn't this magnet pick up this floppy disk?</font></small>
+%
+<small><font color="#999999">Dain bramaged.</font></small>
+%
+<small><font color="#999999">DEFINITION: Computer - A device designed to speed and automate errors.</font></small>
+%
+<small><font color="#999999">Demons are a Ghouls best Friend.</font></small>
+%
+<small><font color="#999999">Department of Redundancy Department</font></small>
+%
+<small><font color="#999999">Despite the cost of living, have you noticed how it remains so popular?</font></small>
+%
+<small><font color="#999999">Did anyone see my lost carrier?</font></small>
+%
+<small><font color="#999999">Did ya hear? They took the word gullible out of the dictionary!</font></small>
+%
+<small><font color="#999999">Did you ever notice when you blow in a dog's face he gets mad at you? But when you take him in a car he sticks his head out the window.</font></small>
+%
+<small><font color="#999999">Diplomacy is the art of saying "Nice doggie!" - Until you can find a rock.</font></small>
+%
+<small><font color="#999999">Diplomacy - the art of letting someone have your way.</font></small>
+%
+<small><font color="#999999">Disco is to music what Etch-A-Sketch is to art</font></small>
+%
+<small><font color="#999999">Disinformation is not as good as datinformation.</font></small>
+%
+<small><font color="#999999">Disk Full - Press F1 to belch.</font></small>
+%
+<small><font color="#999999">Do cemetery workers prefer the graveyard shift?</font></small>
+%
+<small><font color="#999999">Does fuzzy logic tickle?</font></small>
+%
+<small><font color="#999999">Does it bother you that doctors call what they do a practice?</font></small>
+%
+<small><font color="#999999">Doesn't "expecting the unexpected" make the unexpected the expected.</font></small>
+%
+<small><font color="#999999">Does your train of thought have a caboose?</font></small>
+%
+<small><font color="#999999">Do fish get cramps after eating?</font></small>
+%
+<small><font color="#999999">Do hungry crows have ravenous appetites?</font></small>
+%
+<small><font color="#999999">Do illiterate people get the full effect of alphabet soup?</font></small>
+%
+<small><font color="#999999">Do infants enjoy infancy as much as adults enjoy adultery?</font></small>
+%
+<small><font color="#999999">Do Lipton Tea employees take coffee breaks?</font></small>
+%
+<small><font color="#999999">Do not meddle in the affairs of dragons, for you are crunchy and taste good toasted.</font></small>
+%
+<small><font color="#999999">Don't be accommodating, be honest. I honestly don't have much more time for anything else.</font></small>
+%
+<small><font color="#999999">Don't be so open-minded your brains fall out.</font></small>
+%
+<small><font color="#999999">Don't bother me. I'm living happily ever after.</font></small>
+%
+<small><font color="#999999">Don't drink and drive... You might hit a bump and spill your drink.</font></small>
+%
+<small><font color="#999999">Don't look back, they might be gaining on you.</font></small>
+%
+<small><font color="#999999">Don't make no sense that common sense don't make no sense no more. - John Prine</font></small>
+%
+<small><font color="#999999">Don't take life too seriously, you won't get out alive.</font></small>
+%
+<small><font color="#999999">Don't tell anyone, but duct tape is The Force. It has a dark side, and a light side, and it binds the Universe together.</font></small>
+%
+<small><font color="#999999">Don't use a big word where a diminutive one will suffice.</font></small>
+%
+<small><font color="#999999">Don't you hate when your hand falls asleep and you know it will be up all night.</font></small>
+%
+<small><font color="#999999">DOS Tip #17: Add DEVICE=FNGRCROS.SYS to CONFIG.SYS</font></small>
+%
+<small><font color="#999999">Double your drive space - delete Windows!</font></small>
+%
+<small><font color="#999999">Do unto others, then run like hell.</font></small>
+%
+<small><font color="#999999">Do witches run spell checkers?</font></small>
+%
+<small><font color="#999999">Do you think that when they asked George Washington for ID that he just whipped out a quarter?</font></small>
+%
+<small><font color="#999999">Dumb Question Department: Been swimming. Smart Answer: No, I was out walking my pet fish!</font></small>
+%
+<small><font color="#999999">DUMBWAITER: one who asks if the kids would care to order dessert.</font></small>
+%
+<small><font color="#999999">Dyslexics of the world, UNTIE!</font></small>
+%
+<small><font color="#999999">Eagles may soar, but weasels don't get sucked into jet engines.</font></small>
+%
+<small><font color="#999999">Earth First! We'll strip mine the other planets later.</font></small>
+%
+<small><font color="#999999">E-mail returned to sender -- insufficient voltage.</font></small>
+%
+<small><font color="#999999">Energizer Bunny arrested, charged with battery.</font></small>
+%
+<small><font color="#999999">Enter any 11-digit prime number to continue...</font></small>
+%
+<small><font color="#999999">E Pluribus Modem</font></small>
+%
+<small><font color="#999999">Error: Keyboard not attached. Press F1 to continue ...</font></small>
+%
+<small><font color="#999999">Error, no keyboard - press F1 to continue.</font></small>
+%
+<small><font color="#999999">Error reading FAT record: Try the SKINNY one? (Y/N)</font></small>
+%
+<small><font color="#999999">Ethernet (n): something used to catch the etherbunny</font></small>
+%
+<small><font color="#999999">Even a mosquito doesn't get a slap on the back until it starts to work.</font></small>
+%
+<small><font color="#999999">Ever notice how fast Windows runs? Neither did I.</font></small>
+%
+<small><font color="#999999">Ever notice how irons have a setting for permanent press? I don't get it...</font></small>
+%
+<small><font color="#999999">Ever notice that anyone going slower than you is an idiot, but anyone going faster is a maniac?</font></small>
+%
+<small><font color="#999999">Ever notice when you blow in a dog's face he gets mad at you, but when you take him in a car he sticks his head out the window?</font></small>
+%
+<small><font color="#999999">Ever stop to think, and forget to start again?</font></small>
+%
+<small><font color="#999999">Ever wonder what the speed of lightning would be if it didn't zigzag?</font></small>
+%
+<small><font color="#999999">Everybody is somebody else's weirdo.</font></small>
+%
+<small><font color="#999999">Everybody repeat after me ...We are all individuals.</font></small>
+%
+<small><font color="#999999">...Every morning is the dawn of a new error...</font></small>
+%
+<small><font color="#999999">Everyone has a photographic memory, some just don't have any film.</font></small>
+%
+<small><font color="#999999">Everyone has the right to be stupid, but your abusing the privilege.</font></small>
+%
+<small><font color="#999999">Everyone hates me because I'm paranoid.</font></small>
+%
+<small><font color="#999999">Everything should be made as simple as possible, but no simpler.</font></small>
+%
+<small><font color="#999999">Everywhere is walking distance if you have the time.</font></small>
+%
+<small><font color="#999999">Excuse me for butting in, but I'm interrupt-driven.</font></small>
+%
+<small><font color="#999999">Experience is something you don't get until just after you need it.</font></small>
+%
+<small><font color="#999999">FATAL ERROR! SYSTEM HALTED! - Press any key to do nothing.</font></small>
+%
+<small><font color="#999999">Fear has its use but cowardice has none. - Mohandas Gandhi</font></small>
+%
+<small><font color="#999999">... File not found. Should I fake it? (Y/N)</font></small>
+%
+<small><font color="#999999">Five out of four people have trouble with fractions.</font></small>
+%
+<small><font color="#999999">For every action, there is an equal and opposite criticism.</font></small>
+%
+<small><font color="#999999">For my birthday I got a humidifier and a de-humidifier...I put them in the same room and let them fight it out...</font></small>
+%
+<small><font color="#999999">For people who like peace and quiet: a phoneless cord.</font></small>
+%
+<small><font color="#999999">For Sale: Parachute. Only used once, never opened, small stain.</font></small>
+%
+<small><font color="#999999">Friction can be a real drag.</font></small>
+%
+<small><font color="#999999">Friends help you move. Real friends help you move bodies.</font></small>
+%
+<small><font color="#999999">Friends may come and go, but enemies accumulate.</font></small>
+%
+<small><font color="#999999">Funny, I don't remember being absent minded.</font></small>
+%
+<small><font color="#999999">Get your facts first, and then you can distort them as much as you please. - Mark Twain</font></small>
+%
+<small><font color="#999999">Give a man a fish and he'll eat for a day, teach a man to phish and he'll suck your bank account dry</font></small>
+%
+<small><font color="#999999">Give a person a fish and you feed them for a day; teach that person to use the Internet and they won't bother you for weeks. </font></small>
+%
+<small><font color="#999999">Give me ambiguity or give me something else.</font></small>
+%
+<small><font color="#999999">Go ahead and take risks....just be sure that everything will turn out OK.</font></small>
+%
+<small><font color="#999999">Going to church does not make you a Christian any more than standing in a garage makes you a car.</font></small>
+%
+<small><font color="#999999">Good health is merely the slowest possible rate at which one can die.</font></small>
+%
+<small><font color="#999999">Good judgment comes from bad experience... Which comes from bad judgment</font></small>
+%
+<small><font color="#999999">Great art is as irrational as great music. It is mad with its own loveliness. - George Jean Nathan</font></small>
+%
+<small><font color="#999999">Half the people you know are below average.</font></small>
+%
+<small><font color="#999999">Hang up and drive.</font></small>
+%
+<small><font color="#999999">Happiness is merely the remission of pain.</font></small>
+%
+<small><font color="#999999">Hard work has a future payoff - Laziness pays off now.</font></small>
+%
+<small><font color="#999999">Have you ever imagined a world with no hypothetical situations?</font></small>
+%
+<small><font color="#999999">Have you noticed since everyone has a camcorder these days no one talks about seeing UFOs like they used to?</font></small>
+%
+<small><font color="#999999">Headline: Bear takes over Disneyland in Pooh D'Etat!</font></small>
+%
+<small><font color="#999999">Help! I'm modeming... and I can't hang up!!!</font></small>
+%
+<small><font color="#999999">Help Wanted: Telepath. You know where to apply.</font></small>
+%
+<small><font color="#999999">Hermits have no peer pressure.</font></small>
+%
+<small><font color="#999999">He's not dead, he's electroencephalographically challenged.</font></small>
+%
+<small><font color="#999999">He who laughs last thinks slowest!</font></small>
+%
+<small><font color="#999999">Hidden DOS secret: add BUGS=OFF to your CONFIG.SYS</font></small>
+%
+<small><font color="#999999">Hit any user to continue.</font></small>
+%
+<small><font color="#999999">Home computers are being called upon to perform many new functions, including the consumption of homework formerly eaten by the dog. - Doug Larson</font></small>
+%
+<small><font color="#999999">Honesty is the best policy, but insanity is a better defense.</font></small>
+%
+<small><font color="#999999">How can you tell when the blue cheese goes bad?</font></small>
+%
+<small><font color="#999999">How come abbreviated is such a long word?</font></small>
+%
+<small><font color="#999999">How come a slight tax increase costs you two hundred dollars and a substantial tax cut saves you thirty cents?</font></small>
+%
+<small><font color="#999999">How come you don't ever hear about gruntled employees? And who has been dissing them anyhow?</font></small>
+%
+<small><font color="#999999">How do you tell when you run out of invisible ink?</font></small>
+%
+<small><font color="#999999">How good bad music and bad reasons sound when we march against an enemy. - Friedrich Nietzsche</font></small>
+%
+<small><font color="#999999">How many of you believe in telekinesis? Raise my hands. . . .</font></small>
+%
+<small><font color="#999999">How much deeper would oceans be if sponges didn't live there?</font></small>
+%
+<small><font color="#999999">Humor is a rubber sword - it allows you to make a point without drawing blood. - Mary Hirsch</font></small>
+%
+<small><font color="#999999">I always take life with a grain of salt, plus a slice of lemon and a shot of tequila.</font></small>
+%
+<small><font color="#999999">I always wanted to be a procrastinator but never got around to it</font></small>
+%
+<small><font color="#999999">I always wanted to be somebody, but I should have been more specific.</font></small>
+%
+<small><font color="#999999">I am in shape. Round is a shape!</font></small>
+%
+<small><font color="#999999">I broke a mirror in my house. I'm supposed to get seven years of bad luck, but my lawyer thinks he can get me five.</font></small>
+%
+<small><font color="#999999">I can please only one person per day. Today is not your day. And tomorrow isn't looking good either.</font></small>
+%
+<small><font color="#999999">I can see clearly now, the brain is gone...</font></small>
+%
+<small><font color="#999999">I can't remember if I'm the good twin or the evil one.</font></small>
+%
+<small><font color="#999999">I'd explain it to you, but your brain would explode.</font></small>
+%
+<small><font color="#999999">I didn't climb to the top of the food chain to be a vegetarian.</font></small>
+%
+<small><font color="#999999">I don't get even, I get odder.</font></small>
+%
+<small><font color="#999999">I don't have a license to kill. I have a learner's permit.</font></small>
+%
+<small><font color="#999999">I don't have a solution but I admire the problem.</font></small>
+%
+<small><font color="#999999">I don't have to take this abuse from you -- I've got hundreds of people waiting to abuse me.</font></small>
+%
+<small><font color="#999999">I don't suffer from insanity. I enjoy every minute of it.</font></small>
+%
+<small><font color="#999999">If 7-11 stores are open 24 hours/7-days a week, why do they have locks on the front door?</font></small>
+%
+<small><font color="#999999">If a book about failures does not sell, is it a success?</font></small>
+%
+<small><font color="#999999">If a cow laughed, would milk come out her nose?</font></small>
+%
+<small><font color="#999999">If all the world is a stage, where is the audience sitting?</font></small>
+%
+<small><font color="#999999">If a man says something in the woods and there are no women there, is he still wrong?</font></small>
+%
+<small><font color="#999999">If a mime is arrested do they tell him he has the right to talk?</font></small>
+%
+<small><font color="#999999">If a mute swears does his mother wash his hands with soap?</font></small>
+%
+<small><font color="#999999">If an orange is orange, why isn't a lime called a green or a lemon called a yellow?</font></small>
+%
+<small><font color="#999999">If a pig loses its voice, is it disgruntled?</font></small>
+%
+<small><font color="#999999">If at first you don't succeed, destroy all evidence that you tried.</font></small>
+%
+<small><font color="#999999">If at first you don't succeed, skydiving is not for you.</font></small>
+%
+<small><font color="#999999">If at first you DO succeed, try not to look astonished!</font></small>
+%
+<small><font color="#999999">If a turtle doesn't have a shell, is he homeless or naked?</font></small>
+%
+<small><font color="#999999">If bankers can count, how come they have eight windows and only four tellers?</font></small>
+%
+<small><font color="#999999">If croutons are stale bread, why do they come in airtight packages?</font></small>
+%
+<small><font color="#999999">If debugging is the process of removing bugs, then programming must be the process of putting them in.</font></small>
+%
+<small><font color="#999999">If electricity comes from electrons, where does morality come from?</font></small>
+%
+<small><font color="#999999">If Fed Ex and UPS were to merge, would they call it Fed UP?</font></small>
+%
+<small><font color="#999999">If God wanted me to touch my toes, he would have put them on my knees.</font></small>
+%
+<small><font color="#999999">If ignorance is bliss, you must be orgasmic.</font></small>
+%
+<small><font color="#999999">If I melted dry ice, could I swim in it and not get wet?</font></small>
+%
+<small><font color="#999999">If I only had a little humility, I'd be perfect. - Ted Turner</font></small>
+%
+<small><font color="#999999">If it ain't broke fix it anyway! If it's broke fix it and make it worse!</font></small>
+%
+<small><font color="#999999">If it's true that we are here to help others, then what exactly are the others here for?</font></small>
+%
+<small><font color="#999999">If it's zero degrees outside today and it's supposed to be twice as cold tomorrow, how cold is it going to be?</font></small>
+%
+<small><font color="#999999">If it's zero degrees outside today and it's supposed to be twice as cold tomorrow, how cold is it going to be?</font></small>
+%
+<small><font color="#999999">If I want your opinion, I'll ask you to fill out the necessary forms.</font></small>
+%
+<small><font color="#999999">If knees were backwards, what would chairs look like?</font></small>
+%
+<small><font color="#999999">If lawyers are disbarred and clergymen defrocked, doesn't it follow that electricians can be delighted, musicians denoted, cowboys deranged, models deposed, tree surgeons debarked, and dry cleaners depressed?</font></small>
+%
+<small><font color="#999999">If mother always knows best...What happens when two mothers disagree?</font></small>
+%
+<small><font color="#999999">If olive oil comes from olives, where does baby oil come from?</font></small>
+%
+<small><font color="#999999">If one synchronized swimmer drowns, do the rest have to drown too?</font></small>
+%
+<small><font color="#999999">If people from Poland are called Poles, why aren't people from Holland called Holes?</font></small>
+%
+<small><font color="#999999">If quitters never win, and winners never quit, what fool came up with, "Quit while you're ahead"?</font></small>
+%
+<small><font color="#999999">If the odds are a million to one against something occurring, chances are 50-50 it will.</font></small>
+%
+<small><font color="#999999">If the professor on Gilligan's Island can make a radio out of a coconut, why can't he fix a hole in a boat?</font></small>
+%
+<small><font color="#999999">If there is a god, he will understand why I don't believe in him.</font></small>
+%
+<small><font color="#999999">If there's one thing I can't stand, it's intolerance.</font></small>
+%
+<small><font color="#999999">If the world was a logical place, men would ride horses side-saddle.</font></small>
+%
+<small><font color="#999999">If things get any worse, I'll have to ask you to stop helping me.</font></small>
+%
+<small><font color="#999999">If toast always lands butter-side-down, and a cats always land on their feet, what would happen if you strapped a piece of toast on the back of a cat & dropped it?</font></small>
+%
+<small><font color="#999999">If vegetarians eat vegetables, what do humanitarians eat?</font></small>
+%
+<small><font color="#999999">If you believe in telekinesis, raise my hand.</font></small>
+%
+<small><font color="#999999">If you blow into a dog's face, it will drive it crazy. Why is it when you take them for a ride in a car, they stick their head out of the window?</font></small>
+%
+<small><font color="#999999">If you can read this, I can slam on my brakes and sue you.</font></small>
+%
+<small><font color="#999999">If you can smile when things go wrong, you have someone in mind to blame.</font></small>
+%
+<small><font color="#999999">If you can survive death, you can probably survive anything.</font></small>
+%
+<small><font color="#999999">If you can't be kind, at least have the decency to be vague.</font></small>
+%
+<small><font color="#999999">If you drink, don't park. Accidents cause people.</font></small>
+%
+<small><font color="#999999">If you had everything, where would you keep it?</font></small>
+%
+<small><font color="#999999">If you have a difficult task, give it to a lazy person; they'll find an easier way to do it.</font></small>
+%
+<small><font color="#999999">If you mixed vodka with orange juice and Milk Of Magnesia, would you get a Philip's Screwdriver?</font></small>
+%
+<small><font color="#999999">If you must choose between two evils, pick the one you've never tried before.</font></small>
+%
+<small><font color="#999999">If you're cross-eyed and have dyslexia, can you read all right?</font></small>
+%
+<small><font color="#999999">If you're living on the edge, make sure you're wearing your seat belt.</font></small>
+%
+<small><font color="#999999">If you're sending someone some Styrofoam, what do you pack it in?</font></small>
+%
+<small><font color="#999999">If you take an Oriental person and spin him around several times, does he become disoriented?</font></small>
+%
+<small><font color="#999999">If you think nobody cares about you, try missing a couple of payments.</font></small>
+%
+<small><font color="#999999">If you think that there is good in everybody, you haven't met everybody.</font></small>
+%
+<small><font color="#999999">If you were driving your car at the speed of light, and you turned on your headlights. Would anything happen?</font></small>
+%
+<small><font color="#999999">I got a new shadow. I had to get rid of the other one -- it wasn't doing what I was doing.</font></small>
+%
+<small><font color="#999999">I have no choice but to believe in free will. - Randy Wayne White</font></small>
+%
+<small><font color="#999999">I have not failed, I've just found 10,000 ways that won't work. - Thomas Edison</font></small>
+%
+<small><font color="#999999">I have seen the truth and it makes no sense.</font></small>
+%
+<small><font color="#999999">I have six locks on my door all in a row. When I go out, I lock every other one. I figure no matter how long somebody stands there picking the locks, they are always locking three.</font></small>
+%
+<small><font color="#999999">I hit the CTRL key but I'm still not in control!</font></small>
+%
+<small><font color="#999999">I intend to live forever - so far, so good</font></small>
+%
+<small><font color="#999999">I just got a physical and asked the doctor, "How do I stand?" He said, "That's what puzzles me!"</font></small>
+%
+<small><font color="#999999">I just got skylights put in my place. The people who live above me are furious!</font></small>
+%
+<small><font color="#999999">I know how I want to die...shot at the age of 108 by a jealous husband!</font></small>
+%
+<small><font color="#999999">I know you believe you understand what you think I said, but I'm not sure you realize that what you heard is not what I meant.</font></small>
+%
+<small><font color="#999999">I know you may think you know what I said, but I'm not sure that you realize that what you think I said is not really what I meant.</font></small>
+%
+<small><font color="#999999">I like kids, but I don't think I could eat a whole one.</font></small>
+%
+<small><font color="#999999">I love deadlines. I especially like the whooshing sound they make as they go flying by.</font></small>
+%
+<small><font color="#999999">I love to go shopping. I love to freak out salespeople. They ask me if they can help me, and I say, "Have you got anything I'd like?" Then they ask me what size I need, and I say, "Extra medium."</font></small>
+%
+<small><font color="#999999">Imagination is more important than knowledge. - Albert Einstein</font></small>
+%
+<small><font color="#999999">I'm all in favor of keeping dangerous weapons out of the hands of fools. Let's start with typewriters. - Solomon Short</font></small>
+%
+<small><font color="#999999">I'm a psychic amnesiac. I know in advance what I'm going to forget.</font></small>
+%
+<small><font color="#999999">I'm a tagline virus, please copy me to your signature file</font></small>
+%
+<small><font color="#999999">I'm desperately trying to figure out why Kamikaze pilots wore helmets.</font></small>
+%
+<small><font color="#999999">I'm not a complete idiot, some parts are missing!</font></small>
+%
+<small><font color="#999999">I'm not into working out. My philosophy is no pain, no pain.</font></small>
+%
+<small><font color="#999999">I'm not schizophrenic, and neither am I.</font></small>
+%
+<small><font color="#999999">I'm not tense, just terribly, terribly alert.</font></small>
+%
+<small><font color="#999999">Indecision is the key to flexibility.</font></small>
+%
+<small><font color="#999999">Individualists of the world, UNITE!</font></small>
+%
+<small><font color="#999999">In love the paradox occurs that two beings become one and yet remain two. - Erich Fromm</font></small>
+%
+<small><font color="#999999">In my house, on the ceilings I have paintings of the rooms above...so I never have to go upstairs.</font></small>
+%
+<small><font color="#999999">In some cultures what I do would be considered normal.</font></small>
+%
+<small><font color="#999999">Instead of talking to your plants, if you yelled a them would they still grow, only to be troubled and insecure?</font></small>
+%
+<small><font color="#999999">I(nternal) R(evenue) S(ervice): We've got what it takes to take what you've got.</font></small>
+%
+<small><font color="#999999">In the 60's, people took acid to make the world appear weird. Now the world is weird and people take Prozac to make it appear normal.</font></small>
+%
+<small><font color="#999999">Introducing LITE - the new way to spell LIGHT with 20% fewer letters!</font></small>
+%
+<small><font color="#999999">I once wanted to become an atheist but I gave up...They have no holidays</font></small>
+%
+<small><font color="#999999">I played a blank tape on full volume. The mime who lived next door complained. So I shot him with a gun with a silencer.</font></small>
+%
+<small><font color="#999999">I put contact lenses in my dog's eyes. They had little pictures of cats on them. Then I took one out and he ran around in circles.</font></small>
+%
+<small><font color="#999999">I put instant coffee in my microwave oven and almost went back in time.</font></small>
+%
+<small><font color="#999999">I said "NO" to drugs, but they didn't listen.</font></small>
+%
+<small><font color="#999999">I see no virtue in outliving my ability to have fun.</font></small>
+%
+<small><font color="#999999">Is French kissing in France just called kissing?</font></small>
+%
+<small><font color="#999999">Is it my imagination, or do buffalo wings taste like chicken?</font></small>
+%
+<small><font color="#999999">Is it time for your medication or mine?</font></small>
+%
+<small><font color="#999999">Is it true that cannibals don't eat clowns because they taste funny?</font></small>
+%
+<small><font color="#999999">I spilled spot remover on my dog and now he's gone.</font></small>
+%
+<small><font color="#999999">Is there another word for synonym?</font></small>
+%
+<small><font color="#999999">I swear by my life and my love of it, that I will never live for the sake of another man, nor ask another man to live for mine</font></small>
+%
+<small><font color="#999999">It doesn't matter what temperature a room is, it's always room temperature.</font></small>
+%
+<small><font color="#999999">I think there is a world market for maybe five computers. - Thomas J. Watson, chairman of IBM, 1943</font></small>
+%
+<small><font color="#999999">I thought about how mothers feed their babies with little tiny spoons and forks so I wonder what Chinese mothers use. Toothpicks?</font></small>
+%
+<small><font color="#999999">It IS as bad as you think, and they ARE out to get you.</font></small>
+%
+<small><font color="#999999">It is bad luck to be superstitious.</font></small>
+%
+<small><font color="#999999">It may be that your sole purpose in life is simply to serve as a warning to others.</font></small>
+%
+<small><font color="#999999">I took an IQ test and the results were negative.</font></small>
+%
+<small><font color="#999999">I tried sniffing Coke once, but the ice cubes froze the end of my nose.</font></small>
+%
+<small><font color="#999999">I tried to backup my hard drive but I couldn't figure out how to put it in reverse</font></small>
+%
+<small><font color="#999999">It's a small world, but I wouldn't want to paint it...</font></small>
+%
+<small><font color="#999999">It's lonely at the top, but you eat better.</font></small>
+%
+<small><font color="#999999">It's not an optical illusion. It just looks like one.</font></small>
+%
+<small><font color="#999999">It's not hard to meet expenses, they're everywhere.</font></small>
+%
+<small><font color="#999999">It's not the pace of life that concerns me, it's the sudden stop at the end.</font></small>
+%
+<small><font color="#999999">I used to be a bartender at the Betty Ford Clinic.</font></small>
+%
+<small><font color="#999999">I used to be clueless about math, but I turned that around 360 degrees.</font></small>
+%
+<small><font color="#999999">I used to be schizophrenic, but we're all right now.</font></small>
+%
+<small><font color="#999999">I used to have a handle on life, then it broke.</font></small>
+%
+<small><font color="#999999">I used to have an open mind but my brains kept falling out.</font></small>
+%
+<small><font color="#999999">I used to work at a factory where they made hydrants; but you couldn't park anywhere near the place.</font></small>
+%
+<small><font color="#999999">I used up all my sick days, so now I'm calling in dead.</font></small>
+%
+<small><font color="#999999">I've always wanted to be somebody, but I should have been more specific.</font></small>
+%
+<small><font color="#999999">I've had amnesia for as long as I can remember.</font></small>
+%
+<small><font color="#999999">I've taken a vow of poverty -- to annoy me, send money</font></small>
+%
+<small><font color="#999999">I've writing a book. I've got the page numbers done.</font></small>
+%
+<small><font color="#999999">I wake up every morning at nine and grab for the morning paper. Then I look at the obituary page. If my name is not on it, I get up. - Benjamin Franklin</font></small>
+%
+<small><font color="#999999">I want to die in my sleep like my grandfather did, not screaming and yelling like the passengers in his car.</font></small>
+%
+<small><font color="#999999">I want to die peacefully in my sleep like my grandfather... Not screaming and yelling like the passengers in his car.</font></small>
+%
+<small><font color="#999999">I was born by Cesarean section, but you really can't tell...except that when I leave my house, I always go out the window...</font></small>
+%
+<small><font color="#999999">I was hitchhiking the other day, and a hearse stopped. I said, "No thanks - I'm not going that far."</font></small>
+%
+<small><font color="#999999">I was self-employed for two years, and boy was my boss a turkey! :-)</font></small>
+%
+<small><font color="#999999">I was once walking through the forest alone. A tree fell right in front of me -- and I didn't hear it.</font></small>
+%
+<small><font color="#999999">I was pulled over for speeding today. The officer said, "Don't you know the speed limit is 55 miles an hour?" I replied, "Yes, but I wasn't going to be out that long.</font></small>
+%
+<small><font color="#999999">I was simply furnishing a home. I love music ... and I don't think a $130,000 indoor-outdoor stereo system is extravagant. - Leona Helmsley</font></small>
+%
+<small><font color="#999999">I was thinking about how people seem to read the Bible a whole lot more as they get older, then it dawned on me . .they were cramming for their finals..</font></small>
+%
+<small><font color="#999999">I was trying to daydream, but my mind kept wandering.</font></small>
+%
+<small><font color="#999999">I went for a walk last night and my kids asked me how long I'd be gone. I said, "The whole time."</font></small>
+%
+<small><font color="#999999">I went to a bookstore and asked the saleswoman where the Self Help section was, she said if she told me it would defeat the purpose</font></small>
+%
+<small><font color="#999999">I went to a general store, but they wouldn't let me buy anything specific.</font></small>
+%
+<small><font color="#999999">I went to a restaurant that serves "breakfast at any time". So I ordered French Toast during the Renaissance.</font></small>
+%
+<small><font color="#999999">I wonder how much deeper would the ocean be without sponges.</font></small>
+%
+<small><font color="#999999">I won't rise to the occasion, but I'll slide over to it.</font></small>
+%
+<small><font color="#999999">I wrote a song, but I can't read music. Every time I hear a new song on the radio I think "Hey, maybe I wrote that."</font></small>
+%
+<small><font color="#999999">Just because I have a short attention span doesn't mean I ... um ... er ... uh ...</font></small>
+%
+<small><font color="#999999">Just because you're paranoid doesn't mean they're not out to get you.</font></small>
+%
+<small><font color="#999999">Just before someone gets nervous, do they experience cocoons in their stomach?</font></small>
+%
+<small><font color="#999999">Just for today, I will not sit in my living room all day in my underwear. Instead, I will move my computer into the bedroom.</font></small>
+%
+<small><font color="#999999">Just remember one thing in life - no matter where you go - there you are.</font></small>
+%
+<small><font color="#999999">Just what part of "NO" didn't you understand?</font></small>
+%
+<small><font color="#999999">Just what the hell was the best thing BEFORE sliced bread?</font></small>
+%
+<small><font color="#999999">Keep honking while I reload.</font></small>
+%
+<small><font color="#999999">Last night I played a blank tape at full blast. The mime next door went nuts.</font></small>
+%
+<small><font color="#999999">Law of Probability Dispersal: Whatever it is that hits the fan will not be evenly distributed.</font></small>
+%
+<small><font color="#999999">Lead me not into temptation (I can find the way myself).</font></small>
+%
+<small><font color="#999999">Life is a salad bar and I just keep banging my head on the sneeze guard.</font></small>
+%
+<small><font color="#999999">Living on Earth may be expensive, but it includes an annual trip around the sun.</font></small>
+%
+<small><font color="#999999">Look out for #1. Don't step in #2 either.</font></small>
+%
+<small><font color="#999999">Lottery: A tax on people who are bad at math.</font></small>
+%
+<small><font color="#999999">Love is always bestowed as a gift - freely, willingly and without expectation. We don't love to be loved; we love to love. - Leo Buscaglia</font></small>
+%
+<small><font color="#999999">Love is like war: easy to begin but very hard to stop. - H. L. Mencken</font></small>
+%
+<small><font color="#999999">Love is the triumph of imagination over intelligence. - H. L. Mencken</font></small>
+%
+<small><font color="#999999">Madness takes its toll. Please have exact change.</font></small>
+%
+<small><font color="#999999">Make it idiot proof and someone will make a better idiot.</font></small>
+%
+<small><font color="#999999">Making music should not be left to the professionals. - Michelle Shocked</font></small>
+%
+<small><font color="#999999">Maybe some lonesome picker will find some healing in my songs. - John Stewart</font></small>
+%
+<small><font color="#999999">Mental Floss prevents Moral Decay.</font></small>
+%
+<small><font color="#999999">Middle Age is when actions creak louder than words</font></small>
+%
+<small><font color="#999999">"More hay, Trigger?" "No thanks, Roy, I'm stuffed!"</font></small>
+%
+<small><font color="#999999">Music expresses that which cannot be said and on which it is impossible to be silent. - Victor Hugo</font></small>
+%
+<small><font color="#999999">Music is essentially useless, as life is. - George Santayana </font></small>
+%
+<small><font color="#999999">Music is the art which is most nigh to tears and memory. - Oscar Wilde</font></small>
+%
+<small><font color="#999999">Music, I suppose, will be the thing that sustains me when I'm too old for sex, and not quite ready to meet God. - Dolly Parton</font></small>
+%
+<small><font color="#999999">My friend has a baby. I'm writing down all the noises he makes so later I can ask him what he meant.</font></small>
+%
+<small><font color="#999999">My software never has bugs. It just develops random features.</font></small>
+%
+<small><font color="#999999">My wife keeps complaining I never listen to her ...or something like that.</font></small>
+%
+<small><font color="#999999">Never argue with a fool; he will soon beat you with his experience.</font></small>
+%
+<small><font color="#999999">Never raise your hands to your kids. It leaves your groin unprotected.</font></small>
+%
+<small><font color="#999999">Never wrestle with a pig. You both get dirty and the pig likes it.</font></small>
+%
+<small><font color="#999999">NEWS FLASH! This just in from the Department of Redundancy Department ...</font></small>
+%
+<small><font color="#999999">No one ever says, "It's only a game", when their team is winning.</font></small>
+%
+<small><font color="#999999">Nostalgia isn't what it used to be.</font></small>
+%
+<small><font color="#999999">Nothing is foolproof to a sufficiently talented fool.</font></small>
+%
+<small><font color="#999999">Nothing says poor craftsmanship more than wrinkled duct tape.</font></small>
+%
+<small><font color="#999999">Not one shred of evidence supports the notion that life is serious.</font></small>
+%
+<small><font color="#999999">Now they show you how detergents take out bloodstains. I think if you've got a T-shirt with a bloodstains all over it, maybe laundry isn't your biggest problem. Maybe you should get rid of the body before you do the wash.</font></small>
+%
+<small><font color="#999999">Okay, who put a "stop payment" on my reality check?</font></small>
+%
+<small><font color="#999999">Old age is when you still have something on the ball but you are just too tired to bounce it.</font></small>
+%
+<small><font color="#999999">Old dog still learning - please don't shoot yet</font></small>
+%
+<small><font color="#999999">Old is when an "All-Nighter" means not getting up to pee</font></small>
+%
+<small><font color="#999999">Old quarterbacks never die, they just fade back and pass</font></small>
+%
+<small><font color="#999999">One nice thing about egoists: They don't talk about other people.</font></small>
+%
+<small><font color="#999999">One of the great tragedies of life is the murder of a beautiful theory by a gang of brutal facts. - Benjamin Franklin</font></small>
+%
+<small><font color="#999999">One reason most people play golf is to wear clothes they wouldn't be caught dead in otherwise.</font></small>
+%
+<small><font color="#999999">One-seventh of your life is spent on Monday.</font></small>
+%
+<small><font color="#999999">One tequila, two tequila, three tequila, floor.</font></small>
+%
+<small><font color="#999999">One time a cop pulled me over for running a stop sign. He said "Didn't you see the stop sign." I said "Yeah, but I don't believe everything I read."</font></small>
+%
+<small><font color="#999999">Only in America are there handicap parking places in front of a skating rink.</font></small>
+%
+<small><font color="#999999">Only in America can a pizza get to your house faster than an ambulance.</font></small>
+%
+<small><font color="#999999">On the keyboard of life, always keep one finger on the escape key.</font></small>
+%
+<small><font color="#999999">Oooo, baby, it's a big old goofy world. - John Prine</font></small>
+%
+<small><font color="#999999">Oops. My brain just hit a bad sector.</font></small>
+%
+<small><font color="#999999">Out of my mind. Back in five minutes.</font></small>
+%
+<small><font color="#999999">Part of the inhumanity of the computer is that, once it is competently programmed and working smoothly, it is completely honest. - Isaac Asimov</font></small>
+%
+<small><font color="#999999">Patience has its limits. Take it too far, and it's cowardice. - George Jackson</font></small>
+%
+<small><font color="#999999">Pentiums melt in your PC, not in your hand.</font></small>
+%
+<small><font color="#999999">Photons have mass? I didn't even know they were Catholic.</font></small>
+%
+<small><font color="#999999">Plan to be spontaneous tomorrow.</font></small>
+%
+<small><font color="#999999">Please, Lord, let me prove that winning the lottery won't spoil me.</font></small>
+%
+<small><font color="#999999">Prediction is very difficult, especially about the future. - Niels Bohr</font></small>
+%
+<small><font color="#999999">Press any key... no, no, no, NOT THAT ONE!</font></small>
+%
+<small><font color="#999999">Press any key to continue or any other key to quit...</font></small>
+%
+<small><font color="#999999">Press CTRL-ALT-DEL to continue ...</font></small>
+%
+<small><font color="#999999">Programmer - A red-eyed, mumbling mammal capable of conversing with inanimate objects.</font></small>
+%
+<small><font color="#999999">Programmers don't die, they just GOSUB without RETURN.</font></small>
+%
+<small><font color="#999999">Proofread carefully to see if you any words out.</font></small>
+%
+<small><font color="#999999">Puritanism: The haunting fear that someone, somewhere may be happy.</font></small>
+%
+<small><font color="#999999">Question: Why do people always seem to find things in the last place that they look? Answer: Because most people stop looking after they find it!</font></small>
+%
+<small><font color="#999999">RAM disk is *not* an installation procedure.</font></small>
+%
+<small><font color="#999999">Read my chips: No new upgrades!</font></small>
+%
+<small><font color="#999999">Reality is a crutch for people who can't handle drugs.</font></small>
+%
+<small><font color="#999999">REALITY.SYS corrupted: Reboot universe? (Y/N/Q)</font></small>
+%
+<small><font color="#999999">Real programmers don't document. If it was hard to write, it should be to understand.</font></small>
+%
+<small><font color="#999999">Right now I'm having vu ja de--deja vu and amnesia at the same time. I could have sworn I forgot this before!</font></small>
+%
+<small><font color="#999999">Save the whales! Trade them for valuable prizes.</font></small>
+%
+<small><font color="#999999">Seen it all, done it all, can't remember most of it.</font></small>
+%
+<small><font color="#999999">SENILE.COM found . . . Out Of Memory . . .</font></small>
+%
+<small><font color="#999999">Shell to DOS... Come in DOS, do you copy? Shell to DOS...</font></small>
+%
+<small><font color="#999999">Shin: A device for finding furniture in the dark.</font></small>
+%
+<small><font color="#999999">Show me a man with both feet firmly on the ground, and I'll show you a man who can't get his pants off.</font></small>
+%
+<small><font color="#999999">Sign seen in a bar: "Those drinking to forget please pay in advance"</font></small>
+%
+<small><font color="#999999">Since light travels faster than sound, isn't that why some people appear bright until you hear them speak?</font></small>
+%
+<small><font color="#999999">Smash forehead on keyboard to continue.....</font></small>
+%
+<small><font color="#999999">Someone who thinks logically is a nice contrast to the real world.</font></small>
+%
+<small><font color="#999999">Some people are like Slinkies . . not really good for anything, but you still can't help but smile when you see one tumble down the stairs.</font></small>
+%
+<small><font color="#999999">Some people are only alive because it is illegal to shoot them.</font></small>
+%
+<small><font color="#999999">Some people just don't know how to drive, I call these people "Everybody But Me." </font></small>
+%
+<small><font color="#999999">Some people say "life is short". What?? Life is the longest damn thing anyone ever does!! What can you do that's longer?</font></small>
+%
+<small><font color="#999999">Sometimes I think it's a shame when I get feelin' better when I'm feelin' no pain. - Gordon Lightfoot</font></small>
+%
+<small><font color="#999999">Sometimes too much drink is not enough.</font></small>
+%
+<small><font color="#999999">Southern DOS: Y'all reckon? (Yep/Nope)</font></small>
+%
+<small><font color="#999999">So what's the speed of dark?</font></small>
+%
+<small><font color="#999999">Sped up my XT; ran it on 220v! Works greO?_~"</font></small>
+%
+<small><font color="#999999">Stop repeat offenders. Don't re-elect them!</font></small>
+%
+<small><font color="#999999">Suburbia: where they tear out the trees & then name streets after them.</font></small>
+%
+<small><font color="#999999">Success always occurs in private, and failure in full view.</font></small>
+%
+<small><font color="#999999">Suicidal twin kills sister by mistake!</font></small>
+%
+<small><font color="#999999">Suicide is the most sincere form of self-criticism.</font></small>
+%
+<small><font color="#999999">Sure you can trust the government! Just ask an Indian!</font></small>
+%
+<small><font color="#999999">Take my advice; I don't use it anyway.</font></small>
+%
+<small><font color="#999999">Taxation with representation isn't so hot, either!</font></small>
+%
+<small><font color="#999999">Tell a man that there are 400 billion stars and he'll believe you. Say a bench has wet paint and he has to touch it.</font></small>
+%
+<small><font color="#999999">That's a hell of an ambition, to be mellow. It's like wanting to be senile. - Randy Newman</font></small>
+%
+<small><font color="#999999">That's the beer that made Mel Famie walk us.</font></small>
+%
+<small><font color="#999999">The 2 most common elements in the universe are hydrogen and stupidity.</font></small>
+%
+<small><font color="#999999">The beatings will continue until morale improves.</font></small>
+%
+<small><font color="#999999">The careful application of terror is also a form of communication.</font></small>
+%
+<small><font color="#999999">The chance that you'll forget something is directly proportional to ... to ... uh ...</font></small>
+%
+<small><font color="#999999">The colder the X-ray table, the more of your body is required on it.</font></small>
+%
+<small><font color="#999999">The cost of living hasn't affected its popularity.</font></small>
+%
+<small><font color="#999999">The Definition of an Upgrade: Take old bugs out, put new ones in.</font></small>
+%
+<small><font color="#999999">The easiest way to find something lost around the house is to buy a replacement.</font></small>
+%
+<small><font color="#999999">The facts, although interesting, are irrelevant.</font></small>
+%
+<small><font color="#999999">The gene pool could use a little chlorine.</font></small>
+%
+<small><font color="#999999">The hilarious thing about self-important self-righteous people is that they are so easily baited.</font></small>
+%
+<small><font color="#999999"><-------- The information went data way --------></font></small>
+%
+<small><font color="#999999">The more you complain, the longer God makes you live.</font></small>
+%
+<small><font color="#999999">The more you run over a dead cat, the flatter it gets.</font></small>
+%
+<small><font color="#999999">The name is Baud......, James Baud.</font></small>
+%
+<small><font color="#999999">The nice thing about Standards is there are so many to choose from. - Michael Santovec</font></small>
+%
+<small><font color="#999999">The obituaries in the newspaper prove beyond a shadow of a doubt that people die in alphabetical order.</font></small>
+%
+<small><font color="#999999">The only difference between a grave and a rut is the depth.</font></small>
+%
+<small><font color="#999999">The other day I was playing poker with Tarot cards. I got a full house and four people died.</font></small>
+%
+<small><font color="#999999">The problem with the gene pool is that there is no lifeguard.</font></small>
+%
+<small><font color="#999999">There are 3 kinds of people in this world. Those who can count and those who can't.</font></small>
+%
+<small><font color="#999999">There cannot be a crisis today; my schedule is already full.</font></small>
+%
+<small><font color="#999999">There is absolutely no substitute for a genuine lack of preparation.</font></small>
+%
+<small><font color="#999999">There is always one more imbecile than you counted on.</font></small>
+%
+<small><font color="#999999">There is no reason anyone would want a computer in their home. - Ken Olson, president, chairman and founder of Digital Equipment Corp., 1977</font></small>
+%
+<small><font color="#999999">There is one thing I would break up over and that is if she caught me with another woman. I wouldn't stand for that. - Steve Martin</font></small>
+%
+<small><font color="#999999">There's a fine line between fishing and standing on the shore looking like an idiot.</font></small>
+%
+<small><font color="#999999">There's nothing more annoying than Stravinsky or the Sex Pistols being drowned out by "You've got mail!"</font></small>
+%
+<small><font color="#999999">There's no trick to being a humorist when you have the whole government working for you. - Will Rogers</font></small>
+%
+<small><font color="#999999">There's only two things that money can't buy and that's true love and home grown tomatoes. - Guy Clark</font></small>
+%
+<small><font color="#999999">There's too much blood in my caffeine system.</font></small>
+%
+<small><font color="#999999">The secret of the universe is @*&^^^ NO CARRIER</font></small>
+%
+<small><font color="#999999">The trouble with doing something right the first time is that nobody appreciates how difficult it was.</font></small>
+%
+<small><font color="#999999">The trouble with life is, that you're halfway through it before you realize that it's a "do it yourself" thing.</font></small>
+%
+<small><font color="#999999">They show you how detergents take out bloodstains. I think if you've got a T-shirt with bloodstains all over it, maybe your laundry isn't your biggest problem.</font></small>
+%
+<small><font color="#999999">Things are more like they are today than they ever were before.</font></small>
+%
+<small><font color="#999999">Think "honk" if you're telepathic.</font></small>
+%
+<small><font color="#999999">This is as bad as it can get, but don't bet on it.</font></small>
+%
+<small><font color="#999999">Those are my principles. If you don't like them I have others.</font></small>
+%
+<small><font color="#999999">Time is nature's way of keeping everything from happening all at once.</font></small>
+%
+<small><font color="#999999">Today I dialed a wrong number....The other side said, "Hello?" and I said, "Hello, could I speak to Joey?" They said," Uh, I don't think so...He's only two months old." I said, "I'll wait..."</font></small>
+%
+<small><font color="#999999">Today I met with a subliminal advertising executive for just a second.</font></small>
+%
+<small><font color="#999999">Too many clicks spoil the browse</font></small>
+%
+<small><font color="#999999">Too many freaks, not enough circuses.</font></small>
+%
+<small><font color="#999999">Try not to let your mind wander. it's too small and fragile to be out by itself.</font></small>
+%
+<small><font color="#999999">Two cannibals are eating a clown. One says to the other: "Does this taste funny to you?"</font></small>
+%
+<small><font color="#999999">Ultimate office automation: networked coffee.</font></small>
+%
+<small><font color="#999999">Unable to close TROUSER.ZIP! - Replace floppy and retry (Y/N)</font></small>
+%
+<small><font color="#999999">Very funny Scotty - now beam down my clothes.</font></small>
+%
+<small><font color="#999999">Violence is the last refuge of the incompetent. - Isaac Asimov</font></small>
+%
+<small><font color="#999999">We are born naked, wet and hungry. Then things get worse.</font></small>
+%
+<small><font color="#999999">We don't like their sound, and guitar music is on the way out. -Decca Recording Co. rejecting the Beatles, 1962.</font></small>
+%
+<small><font color="#999999">We have enough youth. How about a fountain of smart?</font></small>
+%
+<small><font color="#999999">We win justice quickest by rendering justice to the other party. - Mohandas Gandhi</font></small>
+%
+<small><font color="#999999">What do people in China call their good plates?</font></small>
+%
+<small><font color="#999999">What do you do when you see an endangered animal that eats only endangered plants?</font></small>
+%
+<small><font color="#999999">Whatever happened to Preparations A through G?</font></small>
+%
+<small><font color="#999999">What hair color do they put on the driver's licenses of bald men?</font></small>
+%
+<small><font color="#999999">What happened to the first 6 ups?</font></small>
+%
+<small><font color="#999999">What happens if you get scared half-to-death twice?</font></small>
+%
+<small><font color="#999999">What has four legs and an arm? A happy pit bull.</font></small>
+%
+<small><font color="#999999">What if there were no hypothetical questions?</font></small>
+%
+<small><font color="#999999">What is a "free" gift ? Aren't all gifts free?</font></small>
+%
+<small><font color="#999999">What is the speed of dark?</font></small>
+%
+<small><font color="#999999">What's another word for synonym?</font></small>
+%
+<small><font color="#999999">What's another word for thesaurus?</font></small>
+%
+<small><font color="#999999">What's so great about sliced bread? Isn't the bread slicer really more impressive?</font></small>
+%
+<small><font color="#999999">When cheese gets it's picture taken, what does it say?</font></small>
+%
+<small><font color="#999999">Whenever I feel the need to exercise, I lie down till the feeling goes away.</font></small>
+%
+<small><font color="#999999">When everything's coming your way, you're in the wrong lane.</font></small>
+%
+<small><font color="#999999">When God is amazed, does he say: "Oh my Me!"?</font></small>
+%
+<small><font color="#999999">When it rains, why don't sheep shrink?</font></small>
+%
+<small><font color="#999999">When it's your lie, you can tell it any way you want</font></small>
+%
+<small><font color="#999999">When someone asks you, "A penny for your thoughts?" and you put your two cents in, what happens to the other penny?</font></small>
+%
+<small><font color="#999999">When something is "new and improved!". Which is it? If it's new, then there has never been anything before it. If it's an improvement, then there must have been something before it.</font></small>
+%
+<small><font color="#999999">When there's a will, I want to be in it.</font></small>
+%
+<small><font color="#999999">When you do a good deed, get a receipt - In case heaven is like the IRS.</font></small>
+%
+<small><font color="#999999">When you open a new bag of cotton balls, are you supposed to throw the top one away?</font></small>
+%
+<small><font color="#999999">When your pet bird sees you reading the newspaper, does he wonder why you're just sitting there, staring at carpeting?</font></small>
+%
+<small><font color="#999999">Where do forest rangers go to get away from it all?</font></small>
+%
+<small><font color="#999999">Whitewater is over when the First Lady sings.</font></small>
+%
+<small><font color="#999999">Who's General Failure & why's he reading my disk?</font></small>
+%
+<small><font color="#999999">Who so loves believes the impossible. - Elizabeth Barrett Browning</font></small>
+%
+<small><font color="#999999">Who was the first person to look at a cow and say, "I think I'll squeeze these dangly things here and drink whatever comes out"?</font></small>
+%
+<small><font color="#999999">Why are a wise man and a wise guy opposites?</font></small>
+%
+<small><font color="#999999">Why are builders afraid to have a 13th floor but book publishers aren't afraid to have Chapter 11?</font></small>
+%
+<small><font color="#999999">Why are cigarettes sold in gas stations when you can't smoke there?</font></small>
+%
+<small><font color="#999999">Why are there 5 syllables in the word monosyllabic?</font></small>
+%
+<small><font color="#999999">Why are there interstate highways in Hawaii?</font></small>
+%
+<small><font color="#999999">Why are there tags on blow-dryers that say Do Not Use In The Shower? Is this really a problem?</font></small>
+%
+<small><font color="#999999">Why are they called apartments, when they're all stuck together?</font></small>
+%
+<small><font color="#999999">Why are they called stairs inside but steps outside?</font></small>
+%
+<small><font color="#999999">Why can't women put on mascara with their mouth closed?</font></small>
+%
+<small><font color="#999999">Why can we shop in a store but we can't store in a shop?</font></small>
+%
+<small><font color="#999999">Why do ballet dancers always dance on their toes? Wouldn't it be easier to just hire taller dancers?</font></small>
+%
+<small><font color="#999999">Why do banks charge you a non-sufficient funds fee on money they already know you don't have?</font></small>
+%
+<small><font color="#999999">Why do croutons come in airtight packages? It's just stale bread to begin with.</font></small>
+%
+<small><font color="#999999">Why does a cowboy have two spurs? If one side of the horse goes, so does the other.</font></small>
+%
+<small><font color="#999999">Why does mineral water that has trickled through mountains for centuries have a "use by" date?</font></small>
+%
+<small><font color="#999999">Why doesn't DOS ever say "EXCELLENT command or filename!"</font></small>
+%
+<small><font color="#999999">Why doesn't the glue stick to the inside of the bottle?</font></small>
+%
+<small><font color="#999999">Why does your gynecologist leave the room when you get undressed?</font></small>
+%
+<small><font color="#999999">Why don't they just make mouse-flavored cat food?</font></small>
+%
+<small><font color="#999999">Why do overlook and oversee mean opposite things?</font></small>
+%
+<small><font color="#999999">Why do people ask "Can I ask you a question?".... Didn't really give me a choice there, did ya sunshine?</font></small>
+%
+<small><font color="#999999">Why do people ask "Has the bus come yet"? If the bus came would I be standing here!</font></small>
+%
+<small><font color="#999999">Why do people leave cars worth tens of thousands of dollars in the driveway and leave useless things and junk in boxes in the garage?</font></small>
+%
+<small><font color="#999999">Why do people point to their wrist when asking for the time, but not to their crotch when they ask where the toilet is?</font></small>
+%
+<small><font color="#999999">Why do people say "did you see that" when watching a movie at the theater? No, I paid $12 to come to the cinema and stare at the floor!</font></small>
+%
+<small><font color="#999999">Why do people say "Oh you just want to have your cake and eat it too". Damn right! What good is a cake if you can't eat it?</font></small>
+%
+<small><font color="#999999">Why do psychics have to ask you for your name?</font></small>
+%
+<small><font color="#999999">Why do the Alphabet song and Twinkle, Twinkle Little Star have the same tune?</font></small>
+%
+<small><font color="#999999">Why do they call it the Department of Interior when they are in charge of everything outdoors?</font></small>
+%
+<small><font color="#999999">Why do they put pictures of criminals up in the Post Office? What are we supposed to do, write to them? Why don't they just put their pictures on the postage stamps so the mailmen could look for them while they delivered the mail?</font></small>
+%
+<small><font color="#999999">Why do they report power outages on TV?</font></small>
+%
+<small><font color="#999999">Why do they sterilize needles for lethal injections?</font></small>
+%
+<small><font color="#999999">Why do toasters always have a setting that burns the toast to a horrible crisp no one would eat?</font></small>
+%
+<small><font color="#999999">Why do we buy hot dogs in packages of ten and buns in packages of eight?</font></small>
+%
+<small><font color="#999999">Why do we drive on parkways and park on driveways?</font></small>
+%
+<small><font color="#999999">Why do we play in recitals and recite in plays?</font></small>
+%
+<small><font color="#999999">Why do we say something is out of whack? What's a whack?</font></small>
+%
+<small><font color="#999999">Why do women wear evening gowns to nightclubs? Shouldn't they be wearing night gowns?</font></small>
+%
+<small><font color="#999999">Why do you always turn down your radio when looking for an address?</font></small>
+%
+<small><font color="#999999">Why do you need a driver's license to buy alcohol when you can't drink and drive?</font></small>
+%
+<small><font color="#999999">Why is "abbreviation" such a long word?</font></small>
+%
+<small><font color="#999999">Why is a man who invests all your money called a broker?</font></small>
+%
+<small><font color="#999999">Why is a person who plays the piano called a pianist, but a person who drives a race car not called a racist?</font></small>
+%
+<small><font color="#999999">Why is it called Alcoholics Anonymous when the first thing you do is stand up and say, "My name is Bob, and I am an alcoholic"?</font></small>
+%
+<small><font color="#999999">Why is it that anybody going slower than you is an idiot, and anyone going faster is a maniac.</font></small>
+%
+<small><font color="#999999">Why is it that the guy who comes up behind you while you're waiting for an elevator presses the already lit button as though he has some magical powers that you don't?</font></small>
+%
+<small><font color="#999999">Why is it that when you transport something by car, it is called a shipment, but when you transport something by ship, it is called cargo?</font></small>
+%
+<small><font color="#999999">Why isn't 11 pronounced "onety one"?</font></small>
+%
+<small><font color="#999999">Why isn't the word phonetic spelled the way is sounds?</font></small>
+%
+<small><font color="#999999">Why is the alphabet in that order? Is it because of that song?</font></small>
+%
+<small><font color="#999999">Why is there a light in the fridge and not in the freezer?</font></small>
+%
+<small><font color="#999999">Why is there only one Monopolies commission?</font></small>
+%
+<small><font color="#999999">Will the information superhighway have any rest stops?</font></small>
+%
+<small><font color="#999999">Windows: Just another pane in the glass.</font></small>
+%
+<small><font color="#999999">Would a fly without wings be called a walk?</font></small>
+%
+<small><font color="#999999">Yes, I guess, they oughtta name a drink after you. - John Prine</font></small>
+%
+<small><font color="#999999">Yesterday I parked my car in a tow-away zone...when I came back the entire area was missing...</font></small>
+%
+<small><font color="#999999">You cannot achieve the impossible without attempting the absurd.</font></small>
+%
+<small><font color="#999999">You can't fall off the floor.</font></small>
+%
+<small><font color="#999999">You can't have everything...Where would you put it?</font></small>
+%
+<small><font color="#999999">You can't tell which way the train went by looking at the track.</font></small>
+%
+<small><font color="#999999">You can't trust dogs to watch your food.</font></small>
+%
+<small><font color="#999999">You have the right to remain silent. Anything you say will be misquoted, then used against you.</font></small>
+%
+<small><font color="#999999">You have to stay in shape. My mother started walking five miles a day when she was 60. She's 97 now and we have no idea where she is.</font></small>
+%
+<small><font color="#999999">You know how it is when you're walking up the stairs, and you get to the top, and you think there's one more step? I'm like that all the time.</font></small>
+%
+<small><font color="#999999">You know how most packages say "Open here"? What if it said, "Open somewhere else?"</font></small>
+%
+<small><font color="#999999">You must be Daddy's little pumpkin, I can tell by the way you roll. - John Prine</font></small>
+%
+<small><font color="#999999">You never really learn to swear until you learn to drive.</font></small>
+%
+<small><font color="#999999">Young at heart. Slightly older in other places.</font></small>
+%
+<small><font color="#999999">You're just jealous because the voices only talk to ME.</font></small>
+%
+<small><font color="#999999">Is it good if a vacuum really sucks?</font></small>
+%
+<small><font color="#999999">Why is the third hand on the watch called the second hand?</font></small>
+%
+<small><font color="#999999">If a word is misspelled in the dictionary, how would we ever know?</font></small>
+%
+<small><font color="#999999">If Webster wrote the first dictionary, where did he find the words?</font></small>
+%
+<small><font color="#999999">Why does "fat chance" and "slim chance" mean the same thing?</font></small>
+%
+<small><font color="#999999">Why do "tug" boats push their barges?</font></small>
+%
+<small><font color="#999999">Why do we sing "Take me out to the ball game" when we are already there?</font></small>
+%
+<small><font color="#999999">Why is it called "after dark" when it really is "after light"?</font></small>
+%
+<small><font color="#999999">If work is so terrific, why do they have to pay you to do it?</font></small>
+%
+<small><font color="#999999">If all the world is a stage, where is the audience sitting?</font></small>
+%
+<small><font color="#999999">If you are cross-eyed and have dyslexia, can you read all right?</font></small>
+%
+<small><font color="#999999">Why do you press harder on the buttons of a remote control when you know the batteries are dead?</font></small>
+%
+<small><font color="#999999">Why do we put suits in garment bags and garments in a suitcase?</font></small>
+%
+<small><font color="#999999">Why do we wash bath towels? Aren't we clean when we use them?</font></small>
+%
+<small><font color="#999999">Ever wonder about those people who spend $2.00 apiece on those little bottles of Evian water? Try spelling Evian backwards</font></small>
+%
+<small><font color="#999999">Isn't making a smoking section in a restaurant like making a peeing section in a swimming pool?</font></small>
+%
+<small><font color="#999999">If 4 out of 5 people SUFFER from diarrhea...does that mean that one enjoys it?</font></small>
+%
+<small><font color="#999999">Can god conceive of something that he can't create or destroy? If so then he's not all powerful. If not then he's not all-knowing.</font></small>
+%
+<small><font color="#999999">Calling atheism a religion is like calling baldness a hair color.</font></small>
+%
+<small><font color="#999999">The only stupid questions are the ones you didn't Google first!</font></small>
+%
+<small><font color="#999999">Don't go around saying the world owes you a living. The world owes you nothing. It was here first.</font></small>
+%
+<small><font color="#999999">Prejudices are what fools use for reason.</font></small>
+%
+<small><font color="#999999">The true triumph of reason is that it enables us to get along with those who do not possess it.</font></small>
+%
+<small><font color="#999999">It is hard to free fools from the chains they revere.</font></small>
+%
+<small><font color="#999999">Anyone who has the power to make you believe absurdities has the power to make you commit injustices.</font></small>
+%
+<small><font color="#999999">One of the penalties for refusing to participate in politics is that you end up being governed by your inferiors.</font></small>
+%
+<small><font color="#999999">No one ever teaches well who wants to teach, or governs well who wants to govern.</font></small>
+%
+<small><font color="#999999">Courage is knowing what not to fear.</font></small>
+%
+<small><font color="#999999">The best argument against democracy is a five-minute conversation with the average voter.</font></small>
+%
+<small><font color="#999999">It has been said that democracy is the worst form of government except all the others that have been tried.</font></small>
+%
+<small><font color="#999999">Think of how stupid the average person is, and realize half of them are stupider than that.</font></small>
+%
+<small><font color="#999999">I still say a church steeple with a lightning rod on top shows a lack of confidence.</font></small>
+%
+<small><font color="#999999">What can be asserted without proof can be dismissed without proof.</font></small>
+%
+<small><font color="#999999">The fact that a believer is happier than a skeptic is no more to the point than the fact that a drunken man is happier than a sober one.</font></small>
+%
+<small><font color="#999999">Accept that some days you're the pigeon, and some days you're the statue.</font></small>
+%
+<small><font color="#999999">Always keep your words soft and sweet, just in case you have to eat them.</font></small>
+%
+<small><font color="#999999">Always wear stuff that will make you look good if you die in the middle of it.</font></small>
+%
+<small><font color="#999999">If you lend someone $20 and never see that person again, it was probably worth it.</font></small>
+%
+<small><font color="#999999">It may be that your sole purpose in life is simply to be kind to others.</font></small>
+%
+<small><font color="#999999">Never put both feet in your mouth at the same time, because then you won't have a leg to stand on.</font></small>
+%
+<small><font color="#999999">Nobody cares if you can't dance well. just get up and dance.</font></small>
+%
+<small><font color="#999999">Since it's the early worm that gets eaten by the bird, sleep late.</font></small>
+%
+<small><font color="#999999">The second mouse gets the cheese.</font></small>
+%
+<small><font color="#999999">Birthdays are good for you. the more you have, the longer you live.</font></small>
+%
+<small><font color="#999999">You may be only one person in the world, but you may also be the world to one person.</font></small>
+%
+<small><font color="#999999">Some mistakes are too much fun to only make once.</font></small>
+%
+<small><font color="#999999">We could learn a lot from crayons... Some are sharp, some are pretty and some are dull. Some have weird names, and all are different colors, but they all have to live in the same box.</font></small>
+%
+<small><font color="#999999">A truly happy person is one who can enjoy the scenery on a detour.</font></small>
+%
+<small><font color="#999999">The journey of a thousand miles begins with a broken fan belt and leaky tire.</font></small>
+%
+<small><font color="#999999">It's always darkest before dawn. So if you're going to steal your neighbor's newspaper, that's the time to do it.</font></small>
+%
+<small><font color="#999999">Don't be irreplaceable. If you can't be replaced, you can't be promoted.</font></small>
+%
+<small><font color="#999999">Never test the depth of the water with both feet.</font></small>
+%
+<small><font color="#999999">Before you criticize someone, you should walk a mile in their shoes. That way, when you criticize them, you're a mile away and you have their shoes.</font></small>
+%
+<small><font color="#999999">Give a man a fish and he will eat for a day. Teach him how to fish, and he will sit in a boat and drink beer all day.</font></small>
+%
+<small><font color="#999999">If you tell the truth, you don't have to remember anything.</font></small>
+%
+<small><font color="#999999">Everyone seems normal until you get to know them.</font></small>
+%
+<small><font color="#999999">There are two theories to arguing with women. Neither one works.</font></small>
+%
+<small><font color="#999999">Never miss a good chance to shut up.</font></small>
+%
+<small><font color="#999999">Never, under any circumstances, take a sleeping pill and a laxative on the same night.</font></small>
+%
+<small><font color="#999999">The box said to install Windows XP/Vista or better - so I installed Linux!</font></small>
+%
+
--- /dev/null
+<style type="text/css">
+a:link {
+ color: white;
+}
+a:visited {
+ color: white;
+}
+a:hover {
+ color: white;
+ background-color: #004080;
+ text-decoration: underline;
+}
+a:active {
+ color: #333;
+}
+.name a:link {
+ color: #fc0;
+}
+.name a:visited {
+ color: #fc0;
+}
+.name a:hover {
+ color: #fc0;
+ background-color: #333;
+ text-decoration: underline;
+}
+.name a:active {
+ color: red;
+}
+td {
+ font: Helvetica Arial Serif
+ font-size: 16px;
+}
+</style>
+<table bgcolor="#666666" border="0" cellpadding="0" cellspacing="0"
+ width="376">
+ <tbody>
+ <tr>
+ <td><a href="http://clearscm.com"><img alt=""
+ src="file:///D:/Profiles/p6258c/My%20Documents/Logo.jpg" border="0"
+ height="84" width="376"></a></td>
+ </tr>
+ <tr>
+ <td style="margin: 10px;">
+ <table border="0" cellpadding="5" cellspacing="0" width="100%">
+ <tbody>
+ <tr>
+ <td valign="top">
+ <div class="name"><a href="http://defaria.com"><b>Andrew
+DeFaria</b></a></div>
+ <table border="0" cellpadding="0" cellspacing="0"
+ width="100%">
+ <tbody>
+ <tr>
+ <td valign="top"><font color="white"><b>President</b></font></td>
+ <td align="right"><a href="http://clearscm.com"><b>ClearSCM,
+Inc.</b></a></td>
+ </tr>
+ <tr>
+ <td> </td>
+ <td align="right"><font color="white" size="-1">1250
+West Grove Parkway #1178</font></td>
+ </tr>
+ <tr>
+ <td><font color="white" size="-1"><i>The power to see
+clearly...</i></font></td>
+ <td align="right"><font color="white" size="-1">Tempe,
+Arizona 85283-4449</font></td>
+ </tr>
+ <tr>
+ <td><font color="white" size="-1"><i>Professional SCM
+Consultants</i></font></td>
+ <td align="right"><font color="white" size="-1">Phone:
+480-220-7526</font></td>
+ </tr>
+ <tr>
+ <td><font color="white"><a href="http://ClearSCM.com">http://ClearSCM.com</a><br>
+ </font></td>
+ <td align="right"><font color="white"><a
+ href="mailto:Info@ClearSCM.com">Info@ClearSCM.com</a></font></td>
+ </tr>
+ </tbody>
+ </table>
+ </td>
+ </tr>
+ </tbody>
+ </table>
+ </td>
+ </tr>
+ </tbody>
+</table>
--- /dev/null
+ForwardX11 yes
+ForwardX11Trusted yes
+StrictHostKeyChecking no
--- /dev/null
+#!/bin/bash
+################################################################################
+#
+# File: $RCSfile: system,v $
+# Revision: $Revision: 1.6 $
+# Description: System specific settings
+# Author: Andrew@DeFaria.com
+# Created: Mon Aug 20 17:35:01 2001
+# Modified: $Date: 2010/06/11 20:42:23 $
+# Language: bash
+#
+# (c) Copyright 2000-2005, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+# This system's name
+export SYSNAME=$(uname -n)
+
+# Strip domains
+SYSNAME=${SYSNAME%%\.*}
+
+# Set to initial cap
+SYSNAME=$(echo ${SYSNAME:0:1} | tr [:lower:] [:upper:])$(echo ${SYSNAME:1} | tr [:upper:] [:lower:])
--- /dev/null
+RCfile for "top with windows" # shameless braggin'
+Id:a, Mode_altscr=0, Mode_irixps=1, Delay_time=3.000, Curwin=0
+Def fieldscur=AEHIOQTWKNMbcdfgjplrsuvyzX
+ winflags=64824, sortindx=10, maxtasks=0
+ summclr=6, msgsclr=1, headclr=2, taskclr=3
+Job fieldscur=ABcefgjlrstuvyzMKNHIWOPQDX
+ winflags=62777, sortindx=0, maxtasks=0
+ summclr=6, msgsclr=6, headclr=7, taskclr=6
+Mem fieldscur=ANOPQRSTUVbcdefgjlmyzWHIKX
+ winflags=62777, sortindx=13, maxtasks=0
+ summclr=5, msgsclr=5, headclr=4, taskclr=5
+Usr fieldscur=ABDECGfhijlopqrstuvyzMKNWX
+ winflags=62777, sortindx=4, maxtasks=0
+ summclr=3, msgsclr=3, headclr=2, taskclr=3
--- /dev/null
+set background=light
+set autoindent
+set autowrite
+syntax enable
+set nocompatible
+set backspace=indent,eol,start
+colorscheme evening
+map! \7f \b
--- /dev/null
+export VUE=true
+. $HOME/.profile
\ No newline at end of file
--- /dev/null
+;;; clearcase.el --- ClearCase/Emacs integration.
+
+;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004 Kevin Esler
+
+;; Author: Kevin Esler <kaesler@us.ibm.com>
+;; Maintainer: Kevin Esler <kaesler@us.ibm.com>
+;; Keywords: clearcase tools
+;; Web home: http://members.verizon.net/~vze24fr2/EmacsClearCase
+
+;; This file is not part of GNU Emacs.
+;;
+;; This program is free software; you can redistribute it and/or modify it under
+;; the terms of the GNU General Public License as published by the Free Software
+;; Foundation; either version 2, or (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful, but WITHOUT
+;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
+;; details.
+
+;; You should have received a copy of the GNU General Public License along with
+;; GNU Emacs; see the file COPYING. If not, write to the Free Software
+;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+;;{{{ Introduction
+
+;; This is a ClearCase/Emacs integration.
+;;
+;;
+;; How to use
+;; ==========
+;;
+;; 0. Make sure you're using Gnu Emacs-20.4 or later or a recent XEmacs.
+;; In general it seems to work better in Gnu Emacs than in XEmacs,
+;; although many XEmacs users have no problems at all with it.
+;;
+;; 1. Make sure that you DON'T load old versions of vc-hooks.el which contain
+;; incompatible versions of the tq package (functions tq-enqueue and
+;; friends). In particular, Bill Sommerfeld's VC/CC integration has this
+;; problem.
+;;
+;; 2. Copy the files (or at least the clearcase.elc file) to a directory
+;; on your emacs-load-path.
+;;
+;; 3. Insert this in your emacs startup file: (load "clearcase")
+;;
+;; When you begin editing in any view-context, a ClearCase menu will appear
+;; and ClearCase Minor Mode will be activated for you.
+;;
+;; Summary of features
+;; ===================
+;;
+;; Keybindings compatible with Emacs' VC (where it makes sense)
+;; Richer interface than VC
+;; Works on NT and Unix
+;; Context sensitive menu (Emacs knows the ClearCase-status of files)
+;; Snapshot view support: update, version comparisons
+;; Can use Emacs Ediff for version comparison display
+;; Dired Mode:
+;; - en masse checkin/out etc
+;; - enhanced display
+;; - browse version tree
+;; Completion of viewnames, version strings
+;; Auto starting of views referenced as /view/TAG/.. (or \\view\TAG\...)
+;; Emacs for editing comments, config specs
+;; Standard ClearCase GUI tools launchable from Emacs menu
+;; - version tree browser
+;; - project browser
+;; - UCM deliver
+;; - UCM rebase
+;; Operations directly available from Emacs menu/keymap:
+;; create-activity
+;; set-activity
+;; mkelem,
+;; checkout
+;; checkin,
+;; unco,
+;; describe
+;; list history
+;; edit config spec
+;; mkbrtype
+;; snapshot view update: file, directory, view
+;; version comparisons using ediff, diff or GUI
+;; find checkouts
+;; annotate version
+;; et al.
+;;
+;; Acknowledgements
+;; ================
+;;
+;; The help of the following is gratefully acknowledged:
+;;
+;; XEmacs support and other bugfixes:
+;;
+;; Rod Whitby
+;; Adrian Aichner
+;;
+;; This was a result of examining earlier versions of VC and VC/ClearCase
+;; integrations and borrowing freely therefrom. Accordingly, the following
+;; are ackowledged as contributors:
+;;
+;; VC/ClearCase integration authors:
+;;
+;; Bill Sommerfeld
+;; Rod Whitby
+;; Andrew Markebo
+;; Andy Eskilsson
+;; Paul Smith
+;; John Kohl
+;; Chris Felaco
+;;
+;; VC authors:
+;;
+;; Eric S. Raymond
+;; Andre Spiegel
+;; Sebastian Kremer
+;; Richard Stallman
+;; Per Cederqvist
+;; ttn@netcom.com
+;; Andre Spiegel
+;; Jonathan Stigelman
+;; Steve Baur
+;;
+;; Other Contributors:
+;;
+;; Alastair Rankine
+;; Andrew Maguire
+;; Barnaby Dalton
+;; Christian Savard
+;; David O'Shea
+;; Dee Zsombor
+;; Gabor Zoka
+;; Jason Rumney
+;; Jeff Phillips
+;; Justin Vallon
+;; Mark Collins
+;; Patrik Madison
+;; Ram Bhamidipaty
+;; Reinhard Hahn
+;; Richard Kim
+;; Richard Y. Kim
+;; Simon Graham
+;; Stephen Leake
+;; Steven E. Harris
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;}}}
+
+;;{{{ Version info
+
+(defconst clearcase-version-stamp "ClearCase-version: </main/laptop/156>")
+(defconst clearcase-version (substring clearcase-version-stamp 19))
+
+(defun clearcase-maintainer-address ()
+ ;; Avoid spam.
+ ;;
+ (concat "kevin.esler.1989"
+ "@"
+ "alum.bu.edu"))
+
+(defun clearcase-submit-bug-report ()
+ "Submit via mail a bug report on ClearCase Mode"
+ (interactive)
+ (and (y-or-n-p "Do you really want to submit a report on ClearCase Mode ? ")
+ (reporter-submit-bug-report
+ (clearcase-maintainer-address)
+ (concat "clearcase.el " clearcase-version)
+ '(
+ system-type
+ system-configuration
+ emacs-version
+ clearcase-clearcase-version-installed
+ clearcase-cleartool-path
+ clearcase-lt
+ clearcase-v3
+ clearcase-v4
+ clearcase-v5
+ clearcase-v6
+ clearcase-servers-online
+ clearcase-disable-tq
+ clearcase-on-cygwin
+ clearcase-setview-root
+ clearcase-suppress-vc-within-mvfs
+ shell-file-name
+ w32-quote-process-args
+ ))))
+
+;;}}}
+
+;;{{{ Macros
+
+(defmacro clearcase-when-debugging (&rest forms)
+ (list 'if 'clearcase-debug (cons 'progn forms)))
+
+(defmacro clearcase-with-tempfile (filename-var &rest forms)
+ `(let ((,filename-var (clearcase-utl-tempfile-name)))
+ (unwind-protect
+ ,@forms
+
+ ;; Cleanup.
+ ;;
+ (if (file-exists-p ,filename-var)
+ (delete-file ,filename-var)))))
+
+;;}}}
+
+;;{{{ Portability
+
+(defvar clearcase-xemacs-p (string-match "XEmacs" emacs-version))
+
+(defvar clearcase-on-mswindows (memq system-type
+ '(windows-nt ms-windows cygwin cygwin32)))
+
+(defvar clearcase-on-cygwin (memq system-type '(cygwin cygwin32)))
+
+(defvar clearcase-sink-file-name
+ (cond
+ (clearcase-on-cygwin "/dev/null")
+ (clearcase-on-mswindows "NUL")
+ (t "/dev/null")))
+
+(defun clearcase-view-mode-quit (buf)
+ "Exit from View mode, restoring the previous window configuration."
+ (progn
+ (cond ((frame-property (selected-frame) 'clearcase-view-window-config)
+ (set-window-configuration
+ (frame-property (selected-frame) 'clearcase-view-window-config))
+ (set-frame-property (selected-frame) 'clearcase-view-window-config nil))
+ ((not (one-window-p))
+ (delete-window)))
+ (kill-buffer buf)))
+
+(defun clearcase-view-mode (arg &optional camefrom)
+ (if clearcase-xemacs-p
+ (let* ((winconfig (current-window-configuration))
+ (was-one-window (one-window-p))
+ (buffer-name (buffer-name (current-buffer)))
+ (clearcase-view-not-visible
+ (not (and (windows-of-buffer buffer-name) ;shortcut
+ (memq (selected-frame)
+ (mapcar 'window-frame
+ (windows-of-buffer buffer-name)))))))
+ (when clearcase-view-not-visible
+ (set-frame-property (selected-frame)
+ 'clearcase-view-window-config winconfig))
+ (view-mode camefrom 'clearcase-view-mode-quit)
+ (setq buffer-read-only nil))
+ (view-mode arg)))
+
+(defun clearcase-port-view-buffer-other-window (buffer)
+ (if clearcase-xemacs-p
+ (switch-to-buffer-other-window buffer)
+ (view-buffer-other-window buffer nil 'kill-buffer)))
+
+(defun clearcase-dired-sort-by-date ()
+ (if (fboundp 'dired-sort-by-date)
+ (dired-sort-by-date)))
+
+;; Copied from emacs-20
+;;
+(if (not (fboundp 'subst-char-in-string))
+ (defun subst-char-in-string (fromchar tochar string &optional inplace)
+ "Replace FROMCHAR with TOCHAR in STRING each time it occurs.
+Unless optional argument INPLACE is non-nil, return a new string."
+ (let ((i (length string))
+ (newstr (if inplace string (copy-sequence string))))
+ (while (> i 0)
+ (setq i (1- i))
+ (if (eq (aref newstr i) fromchar)
+ (aset newstr i tochar)))
+ newstr)))
+
+;;}}}
+
+;;{{{ Require calls
+
+;; nyi: we also use these at the moment:
+;; -view
+;; -ediff
+;; -view
+;; -dired-sort
+
+(require 'cl)
+(require 'comint)
+(require 'dired)
+(require 'easymenu)
+(require 'executable)
+(require 'reporter)
+(require 'ring)
+(or clearcase-xemacs-p
+ (require 'timer))
+
+;; NT Emacs - doesn't use tq.
+;;
+(if (not clearcase-on-mswindows)
+ (require 'tq))
+
+;;}}}
+
+;;{{{ Debugging facilities
+
+;; Setting this to true will enable some debug code.
+;;
+(defvar clearcase-debug nil)
+
+(defun clearcase-trace (string)
+ (clearcase-when-debugging
+ (let ((trace-buf (get-buffer "*clearcase-trace*")))
+ (if trace-buf
+ (save-excursion
+ (set-buffer trace-buf)
+ (goto-char (point-max))
+ (insert string "\n"))))))
+
+(defun clearcase-enable-tracing ()
+ (interactive)
+ (setq clearcase-debug t)
+ (get-buffer-create "*clearcase-trace*"))
+
+(defun clearcase-disable-tracing ()
+ (interactive)
+ (setq clearcase-debug nil))
+
+(defun clearcase-dump ()
+ (interactive)
+ (clearcase-utl-populate-and-view-buffer
+ "*clearcase-dump*"
+ nil
+ (function (lambda ()
+ (clearcase-fprop-dump-to-current-buffer)
+ (clearcase-vprop-dump-to-current-buffer)))))
+
+(defun clearcase-flush-caches ()
+ (interactive)
+ (clearcase-fprop-clear-all-properties)
+ (clearcase-vprop-clear-all-properties))
+
+;;}}}
+
+;;{{{ Customizable variables
+
+(eval-and-compile
+ (condition-case nil
+ (require 'custom)
+ (error nil))
+ (if (and (featurep 'custom)
+ (fboundp 'custom-declare-variable))
+ nil ;; We've got what we needed
+ ;; We have the old custom-library, hack around it!
+ (defmacro defgroup (&rest args)
+ nil)
+ (defmacro defcustom (var value doc &rest args)
+ (` (defvar (, var) (, value) (, doc))))
+ (defmacro defface (face value doc &rest stuff)
+ `(make-face ,face))
+ (defmacro custom-declare-variable (symbol value doc &rest args)
+ (list 'defvar (eval symbol) value doc))))
+
+(defgroup clearcase () "ClearCase Options" :group 'tools :prefix "clearcase")
+
+(defcustom clearcase-keep-uncheckouts t
+ "When true, the contents of an undone checkout will be kept in a file
+with a \".keep\" suffix. Otherwise it will be removed."
+ :group 'clearcase
+ :type 'boolean)
+
+(defcustom clearcase-keep-unhijacks t
+ "When true, the contents of an undone hijack will be kept in a file
+with a \".keep\" suffix. Otherwise it will be removed."
+ :group 'clearcase
+ :type 'boolean)
+
+;; nyi: We could also allow a value of 'prompt here
+;;
+(defcustom clearcase-set-to-new-activity t
+ "*If this variable is non-nil when a new activity is created, that activity
+will be set as the current activity for the view, otherwise no change is made
+to the view's current activity setting."
+ :group 'clearcase
+ :type 'boolean)
+
+(defcustom clearcase-prompt-for-activity-names t
+ "*If this variable is non-nil the user will be prompted for activity names.
+Otherwise, activity names will be generated automatically and will typically
+have the form \"activity011112.155233\". If the name entered is empty sucn an
+internal name will also be generated."
+ :group 'clearcase
+ :type 'boolean)
+
+(defcustom clearcase-make-backup-files nil
+ "*If non-nil, backups of ClearCase files are made as with other files.
+If nil (the default), files under ClearCase control don't get backups."
+ :group 'clearcase
+ :type 'boolean)
+
+(defcustom clearcase-complete-viewtags t
+ "*If non-nil, completion on viewtags is enabled. For sites with thousands of view
+this should be set to nil."
+ :group 'clearcase
+ :type 'boolean)
+
+(defcustom clearcase-minimise-menus nil
+ "*If non-nil, menus will hide rather than grey-out inapplicable choices."
+ :group 'clearcase
+ :type 'boolean)
+
+(defcustom clearcase-auto-dired-mode t
+ "*If non-nil, automatically enter `clearcase-dired-mode' in dired-mode
+for directories in ClearCase."
+ :group 'clearcase
+ :type 'boolean)
+
+(defcustom clearcase-dired-highlight t
+ "If non-nil, highlight reserved files in clearcase-dired buffers."
+ :group 'clearcase
+ :type 'boolean)
+
+(defcustom clearcase-dired-show-view t
+ "If non-nil, show the view tag in dired buffers."
+ :group 'clearcase
+ :type 'boolean)
+
+(defcustom clearcase-verify-pre-mkelem-dir-checkout nil
+ "*If non-nil, prompt before checking out the containing directory
+before creating a new ClearCase element."
+ :group 'clearcase
+ :type 'boolean)
+
+(defcustom clearcase-diff-on-checkin nil
+ "Display diff on checkin to help you compose the checkin comment."
+ :group 'clearcase
+ :type 'boolean)
+
+;; General customization
+
+(defcustom clearcase-suppress-confirm nil
+ "If non-nil, treat user as expert; suppress yes-no prompts on some things."
+ :group 'clearcase
+ :type 'boolean)
+
+(defcustom clearcase-initial-mkelem-comment nil
+ "Prompt for initial comment when an element is created."
+ :group 'clearcase
+ :type 'boolean)
+
+(defcustom clearcase-command-messages nil
+ "Display run messages from back-end commands."
+ :group 'clearcase
+ :type 'boolean)
+
+(defcustom clearcase-checkin-arguments
+ ;; For backwards compatibility with old name for this variable:
+ ;;
+ (if (and (boundp 'clearcase-checkin-switches)
+ (not (null clearcase-checkin-switches)))
+ (list clearcase-checkin-switches)
+ nil)
+ "A list of extra arguments passed to the checkin command."
+ :group 'clearcase
+ :type '(repeat (string :tag "Argument")))
+
+(defcustom clearcase-checkin-on-mkelem nil
+ "If t, file will be checked-in when first created as an element."
+ :group 'clearcase
+ :type 'boolean)
+
+(defcustom clearcase-suppress-checkout-comments nil
+ "Suppress prompts for checkout comments for those version control
+systems which use them."
+ :group 'clearcase
+ :type 'boolean)
+
+(defcustom clearcase-checkout-arguments
+ ;; For backwards compatibility with old name for this variable:
+ ;;
+ (if (and (boundp 'clearcase-checkout-arguments)
+ (not (null clearcase-checkout-arguments)))
+ (list clearcase-checkout-arguments)
+ nil)
+ "A list of extra arguments passed to the checkout command."
+ :group 'clearcase
+ :type '(repeat (string :tag "Argument")))
+
+(defcustom clearcase-directory-exclusion-list '("lost+found")
+ "Directory names ignored by functions that recursively walk file trees."
+ :group 'clearcase
+ :type '(repeat (string :tag "Subdirectory")))
+
+(defcustom clearcase-use-normal-diff nil
+ "If non-nil, use normal diff instead of cleardiff."
+ :group 'clearcase
+ :type 'boolean)
+
+(defcustom clearcase-normal-diff-program "diff"
+ "*Program to use for generating the differential of the two files
+when `clearcase-use-normal-diff' is t."
+ :group 'clearcase
+ :type 'string)
+
+(defcustom clearcase-normal-diff-arguments
+ (if (and (boundp 'clearcase-normal-diff-switches)
+ (not (null clearcase-normal-diff-switches)))
+ (list clearcase-normal-diff-switches)
+ (list "-u"))
+ "A list of extra arguments passed to `clearcase-normal-diff-program'
+when `clearcase-use-normal-diff' is t. Usage of the -u switch is
+recommended to produce unified diffs, when your
+`clearcase-normal-diff-program' supports it."
+ :group 'clearcase
+ :type '(repeat (string :tag "Argument")))
+
+(defcustom clearcase-vxpath-glue "@@"
+ "The string used to construct version-extended pathnames."
+ :group 'clearcase
+ :type 'string)
+
+(defcustom clearcase-viewroot (if clearcase-on-mswindows
+ "//view"
+ "/view")
+ "The ClearCase viewroot directory."
+ :group 'clearcase
+ :type 'file)
+
+(defcustom clearcase-viewroot-drive "m:"
+ "The ClearCase viewroot drive letter for Windows."
+ :group 'clearcase
+ :type 'string)
+
+(defcustom clearcase-suppress-vc-within-mvfs t
+ "Suppresses VC activity within the MVFS."
+ :group 'clearcase
+ :type 'boolean)
+
+(defcustom clearcase-hide-rebase-activities t
+ "Hide rebase activities from activity selection list."
+ :group 'clearcase
+ :type 'boolean)
+
+(defcustom clearcase-rebase-id-regexp "^rebase\\."
+ "The regexp used to detect rebase actvities."
+ :group 'clearcase
+ :type 'string)
+
+;;}}}
+
+;;{{{ Global variables
+
+;; Initialize clearcase-pname-sep-regexp according to
+;; directory-sep-char.
+(defvar clearcase-pname-sep-regexp
+ (format "[%s/]"
+ (char-to-string directory-sep-char)))
+
+(defvar clearcase-non-pname-sep-regexp
+ (format "[^%s/]"
+ (char-to-string directory-sep-char)))
+
+;; Matches any viewtag (without the trailing "/").
+;;
+(defvar clearcase-viewtag-regexp
+ (concat "^"
+ clearcase-viewroot
+ clearcase-pname-sep-regexp
+ "\\("
+ clearcase-non-pname-sep-regexp "*"
+ "\\)"
+ "$"
+ ))
+
+;; Matches ANY viewroot-relative path
+;;
+(defvar clearcase-vrpath-regexp
+ (concat "^"
+ clearcase-viewroot
+ clearcase-pname-sep-regexp
+ "\\("
+ clearcase-non-pname-sep-regexp "*"
+ "\\)"
+ ))
+
+;;}}}
+
+;;{{{ Minor Mode: ClearCase
+
+;; For ClearCase Minor Mode
+;;
+(defvar clearcase-mode nil)
+(set-default 'clearcase-mode nil)
+(make-variable-buffer-local 'clearcase-mode)
+(put 'clearcase-mode 'permanent-local t)
+
+;; Tell Emacs about this new kind of minor mode
+;;
+(if (not (assoc 'clearcase-mode minor-mode-alist))
+ (setq minor-mode-alist (cons '(clearcase-mode clearcase-mode)
+ minor-mode-alist)))
+
+;; For now we override the bindings for VC Minor Mode with ClearCase Minor Mode
+;; bindings.
+;;
+(defvar clearcase-mode-map (make-sparse-keymap))
+(defvar clearcase-prefix-map (make-sparse-keymap))
+(define-key clearcase-mode-map "\C-xv" clearcase-prefix-map)
+(define-key clearcase-mode-map "\C-x\C-q" 'clearcase-toggle-read-only)
+
+(define-key clearcase-prefix-map "b" 'clearcase-browse-vtree-current-buffer)
+(define-key clearcase-prefix-map "c" 'clearcase-uncheckout-current-buffer)
+(define-key clearcase-prefix-map "e" 'clearcase-edcs-edit)
+(define-key clearcase-prefix-map "g" 'clearcase-annotate-current-buffer)
+(define-key clearcase-prefix-map "i" 'clearcase-mkelem-current-buffer)
+(define-key clearcase-prefix-map "l" 'clearcase-list-history-current-buffer)
+(define-key clearcase-prefix-map "m" 'clearcase-mkbrtype)
+(define-key clearcase-prefix-map "u" 'clearcase-uncheckout-current-buffer)
+(define-key clearcase-prefix-map "v" 'clearcase-next-action-current-buffer)
+(define-key clearcase-prefix-map "w" 'clearcase-what-rule-current-buffer)
+(define-key clearcase-prefix-map "=" 'clearcase-diff-pred-current-buffer)
+(define-key clearcase-prefix-map "?" 'clearcase-describe-current-buffer)
+(define-key clearcase-prefix-map "~" 'clearcase-version-other-window)
+
+;; To avoid confusion, we prevent VC Mode from being active at all by
+;; undefining its keybindings for which ClearCase Mode doesn't yet have an
+;; analogue.
+;;
+(define-key clearcase-prefix-map "a" 'undefined) ;; vc-update-change-log
+(define-key clearcase-prefix-map "d" 'undefined) ;; vc-directory
+(define-key clearcase-prefix-map "h" 'undefined) ;; vc-insert-headers
+(define-key clearcase-prefix-map "m" 'undefined) ;; vc-merge
+(define-key clearcase-prefix-map "r" 'undefined) ;; vc-retrieve-snapshot
+(define-key clearcase-prefix-map "s" 'undefined) ;; vc-create-snapshot
+(define-key clearcase-prefix-map "t" 'undefined) ;; vc-dired-toggle-terse-mode
+
+;; Associate the map and the minor mode
+;;
+(or (not (boundp 'minor-mode-map-alist))
+ (assq 'clearcase-mode (symbol-value 'minor-mode-map-alist))
+ (setq minor-mode-map-alist
+ (cons (cons 'clearcase-mode clearcase-mode-map)
+ minor-mode-map-alist)))
+
+(defun clearcase-mode (&optional arg)
+ "ClearCase Minor Mode"
+
+ (interactive "P")
+
+ ;; Behave like a proper minor-mode.
+ ;;
+ (setq clearcase-mode
+ (if (interactive-p)
+ (if (null arg)
+ (not clearcase-mode)
+
+ ;; Check if the numeric arg is positive.
+ ;;
+ (> (prefix-numeric-value arg) 0))
+
+ ;; else
+ ;; Use the car if it's a list.
+ ;;
+ (if (consp arg)
+ (setq arg (car arg)))
+ (if (symbolp arg)
+ (if (null arg)
+ (not clearcase-mode) ;; toggle mode switch
+ (not (eq '- arg))) ;; True if symbol is not '-
+
+ ;; else
+ ;; assume it's a number and check that.
+ ;;
+ (> arg 0))))
+
+ (if clearcase-mode
+ (easy-menu-add clearcase-menu 'clearcase-mode-map))
+ )
+
+;;}}}
+
+;;{{{ Minor Mode: ClearCase Dired
+
+;;{{{ Reformatting the Dired buffer
+
+;; Create a face for highlighting checked out files in clearcase-dired.
+;;
+(if (not (memq 'clearcase-dired-checkedout-face (face-list)))
+ (progn
+ (make-face 'clearcase-dired-checkedout-face)
+ (set-face-foreground 'clearcase-dired-checkedout-face "red")))
+
+(defun clearcase-dired-insert-viewtag ()
+ (save-excursion
+ (progn
+ (goto-char (point-min))
+
+ ;; Only do this if the buffer is not currently narrowed
+ ;;
+ (if (= 1 (point))
+ (let ((viewtag (clearcase-fprop-viewtag (file-truename default-directory))))
+ (if viewtag
+ (progn
+ (forward-line 1)
+ (let ((buffer-read-only nil))
+ (insert (format " [ClearCase View: %s]\n" viewtag))))))))))
+
+(defun clearcase-dired-reformat-buffer ()
+ "Reformats the current dired buffer."
+ (let* ((checkout-list nil)
+ (modified-file-info nil)
+ (hijack-list nil)
+ (directory default-directory)
+ subdir
+ fullpath)
+
+ ;; Iterate over each line in the buffer.
+ ;;
+ ;; Important notes:
+ ;; 1. In general, a Dired buffer can contain listings for several
+ ;; directories. We pass though from top to bottom and adjust
+ ;; subdir as we go.
+ ;; 2. Since this is called from dired-after-reading-hook, it can get
+ ;; called on a single-line buffer. In this case there is no subdir,
+ ;; and no checkout-list. We need to call clearcase-fprop-checked-out
+ ;; to test for a checkout.
+ ;;
+ (save-excursion
+ (goto-char (point-min))
+ (while (not (eobp))
+ (cond
+
+ ;; Case 1: Look for directory markers
+ ;;
+ ((setq subdir (dired-get-subdir))
+
+ ;; We're at a subdirectory line in the dired buffer.
+ ;; Go and list all checkouts and hijacks in this subdirectory.
+ ;;
+ (setq modified-file-info (clearcase-dired-list-modified-files subdir))
+ (setq checkout-list (nth 0 modified-file-info))
+ (setq hijack-list (nth 1 modified-file-info))
+
+ ;; If no checkouts are found, we don't need to check each file, and
+ ;; it's very slow. The checkout-list should contain something so it
+ ;; doesn't attempt to do this.
+ ;;
+ (if (null checkout-list)
+ (setq checkout-list '(nil)))
+ (if (null hijack-list)
+ (setq hijack-list '(nil)))
+ (message "Reformatting %s..." subdir))
+
+ ;; Case 2: Look for files (the safest way to get the filename).
+ ;;
+ ((setq fullpath (dired-get-filename nil t))
+
+ ;; Expand it to get rid of . and .. entries.
+ ;;
+ (setq fullpath (expand-file-name fullpath))
+
+ (setq fullpath (clearcase-path-canonicalise-slashes fullpath))
+
+ ;; Only modify directory listings of the correct format.
+ ;; We replace the GID field with a checkout indicator.
+ ;;
+ (if (looking-at
+ ;; (1) (2) (3) (4)
+ ;; -rw-rw-rw- 1 esler 5 28 Feb 2 16:02 foo.el
+ "..\\([drwxlts-]+ \\) *\\([0-9]+\\) \\([^ ]+\\) *\\([^ ]+ *\\) +[0-9]+\\( [^ 0-9]+ [0-9 ][0-9] .*\\)")
+
+ (let* ((replacement-begin (match-beginning 4))
+ (replacement-end (match-end 4))
+
+ (replacement-length (- replacement-end replacement-begin))
+ (checkout-replacement-text (format "CHECKOUT"))
+ (hijack-replacement-text (format "HIJACK"))
+ (is-checkout (if checkout-list
+ (member fullpath checkout-list)
+ (clearcase-fprop-checked-out fullpath)))
+ (is-hijack (if hijack-list
+ (member fullpath hijack-list)
+ (clearcase-fprop-hijacked fullpath))))
+
+ ;; Highlight the line if the file is checked-out.
+ ;;
+ (if is-checkout
+ (progn
+ ;; Replace the GID field with CHECKOUT.
+ ;;
+ (let ((buffer-read-only nil))
+
+ ;; Pad with replacement text with trailing spaces if necessary.
+ ;;
+ (if (>= replacement-length (length checkout-replacement-text))
+ (setq checkout-replacement-text
+ (concat checkout-replacement-text
+ (make-string (- replacement-length (length checkout-replacement-text))
+ 32))))
+ (goto-char replacement-begin)
+ (delete-char replacement-length)
+ (insert (substring checkout-replacement-text 0 replacement-length)))
+
+ ;; Highlight the checked out files.
+ ;;
+ (if (fboundp 'put-text-property)
+ (let ((buffer-read-only nil))
+ (put-text-property replacement-begin replacement-end
+ 'face 'clearcase-dired-checkedout-face)))
+ )
+ )
+
+ (if is-hijack
+ (progn
+ ;; Replace the GID field with CHECKOUT.
+ ;;
+ (let ((buffer-read-only nil))
+
+ ;; Pad with replacement text with trailing spaces if necessary.
+ ;;
+ (if (>= replacement-length (length hijack-replacement-text))
+ (setq hijack-replacement-text
+ (concat hijack-replacement-text
+ (make-string (- replacement-length (length hijack-replacement-text))
+ 32))))
+ (goto-char replacement-begin)
+ (delete-char replacement-length)
+ (insert (substring hijack-replacement-text 0 replacement-length)))
+
+ ;; Highlight the checked out files.
+ ;;
+ (if (fboundp 'put-text-property)
+ (let ((buffer-read-only nil))
+ (put-text-property replacement-begin replacement-end
+ 'face 'clearcase-dired-checkedout-face)))
+ )
+ )
+
+ ))))
+ (forward-line 1))))
+ (message "Reformatting...Done"))
+
+
+(defun clearcase-path-follow-if-vob-slink (path)
+ (if (clearcase-fprop-file-is-vob-slink-p path)
+
+ ;; It's a slink so follow it.
+ ;;
+ (let ((slink-text (clearcase-fprop-vob-slink-text path)))
+ (if (file-name-absolute-p slink-text)
+ slink-text
+ (concat (file-name-directory path) slink-text)))
+
+ ;; Not an slink.
+ ;;
+ path))
+
+;;{{{ Searching for modified files
+
+;;{{{ Old code
+
+;; (defun clearcase-dired-list-checkouts (directory)
+;; "Returns a list of files checked-out to the current view in DIRECTORY."
+
+;; ;; Don't bother looking for checkouts in
+;; ;; - a history-mode branch-qua-directory
+;; ;; - a view-private directory
+;; ;;
+;; ;; NYI: For now don't run lsco in root of a snapshot because it gives errors.
+;; ;; We need to make this smarter.
+;; ;;
+;; ;; NYI: For a pathname which is a slink to a dir, despite the fact that
+;; ;; clearcase-fprop-file-is-version-p returns true, lsco fails on it,
+;; ;; with "not an element". Sheesh, surely lsco ought to follow links ?
+;; ;; Solution: catch the error and check if the dir is a slink then follow
+;; ;; the link and retry the lsco on the target.
+;; ;;
+;; ;; For now just ignore the error.
+;; ;;
+;; (if (and (not (clearcase-vxpath-p directory))
+;; (not (eq 'view-private-object (clearcase-fprop-mtype directory)))
+;; (clearcase-fprop-file-is-version-p directory))
+
+
+;; (let* ((ignore (message "Listing ClearCase checkouts..."))
+
+;; (true-dir-path (file-truename directory))
+
+;; ;; Give the directory as an argument so all names will be
+;; ;; fullpaths. For some reason ClearCase adds an extra slash if you
+;; ;; leave the trailing slash on the directory, so we need to remove
+;; ;; it.
+;; ;;
+;; (native-dir-path (clearcase-path-native (directory-file-name true-dir-path)))
+
+;; (followed-dir-path (clearcase-path-follow-if-vob-slink native-dir-path))
+
+;; ;; Form the command:
+;; ;;
+;; (cmd (list
+;; "lsco" "-cview" "-fmt"
+;; (if clearcase-on-mswindows
+;; "%n\\n"
+;; "'%n\\n'")
+
+;; followed-dir-path))
+
+;; ;; Capture the output:
+;; ;;
+;; (string (clearcase-path-canonicalise-slashes
+;; (apply 'clearcase-ct-cleartool-cmd cmd)))
+
+;; ;; Split the output at the newlines:
+;; ;;
+;; (checkout-list (clearcase-utl-split-string-at-char string ?\n)))
+
+;; ;; Add entries for "." and ".." if they're checked-out.
+;; ;;
+;; (let* ((entry ".")
+;; (path (expand-file-name (concat (file-name-as-directory true-dir-path)
+;; entry))))
+;; (if (clearcase-fprop-checked-out path)
+;; (setq checkout-list (cons path checkout-list))))
+;; (let* ((entry "..")
+;; (path (expand-file-name (concat (file-name-as-directory true-dir-path)
+;; entry))))
+;; (if (clearcase-fprop-checked-out path)
+;; (setq checkout-list (cons path checkout-list))))
+
+;; ;; If DIRECTORY is a vob-slink, checkout list will contain pathnames
+;; ;; relative to the vob-slink target rather than to DIRECTORY. Convert
+;; ;; them back here. We're making it appear that lsco works on
+;; ;; slinks-to-dirs.
+;; ;;
+;; (if (clearcase-fprop-file-is-vob-slink-p true-dir-path)
+;; (let ((re (regexp-quote (file-name-as-directory followed-dir-path))))
+;; (setq checkout-list
+;; (mapcar
+;; (function
+;; (lambda (path)
+;; (replace-regexp-in-string re true-dir-path path)))
+;; checkout-list))))
+
+;; (message "Listing ClearCase checkouts...done")
+
+;; ;; Return the result.
+;; ;;
+;; checkout-list)
+;; ))
+
+;; ;; I had believed that this implementation below OUGHT to be faster, having
+;; ;; read the code in "ct+lsco". It seemed that "lsco -cview" hit the VOB and
+;; ;; listed all checkouts on all elements in the directory, and then filtered by
+;; ;; view. I thought it would probably be quicker to run "ct ls -vob_only" and
+;; ;; keep the lines that have "[eclipsed by checkout]". However this code
+;; ;; actually seemed to run slower. Leave the code here for now so I can test
+;; ;; further.
+;; ;;
+;; (defun clearcase-dired-list-checkouts-experimental (directory)
+;; "Returns a list of files checked-out to the current view in DIRECTORY."
+
+;; ;; Don't bother looking for checkouts in a history-mode listing
+;; ;; nor in view-private directories.
+;; ;;
+;; (if (and (not (clearcase-vxpath-p directory))
+;; (not (eq 'view-private-object (clearcase-fprop-mtype directory))))
+
+;; (let* ((ignore (message "Listing ClearCase checkouts..."))
+
+;; (true-directory (file-truename directory))
+
+;; ;; Move temporarily to the directory:
+;; ;;
+;; (default-directory true-directory)
+
+;; ;; Form the command:
+;; ;;
+;; (cmd (list "ls" "-vob_only"))
+
+;; ;; Capture the output:
+;; ;;
+;; (string (clearcase-path-canonicalise-slashes
+;; (apply 'clearcase-ct-cleartool-cmd cmd)))
+
+;; ;; Split the output at the newlines:
+;; ;;
+;; (line-list (clearcase-utl-split-string-at-char string ?\n))
+
+;; (checkout-list nil))
+
+;; ;; Look for lines of the form:
+;; ;; FILENAME@@ [eclipsed by checkout]
+;; ;;
+;; (mapcar (function
+;; (lambda (line)
+;; (if (string-match "^\\([^ @]+\\)@@ +\\[eclipsed by checkout\\].*" line)
+;; (setq checkout-list (cons (concat
+;; ;; Add back directory name to get
+;; ;; full pathname.
+;; ;;
+;; default-directory
+;; (substring line
+;; (match-beginning 1)
+;; (match-end 1)))
+;; checkout-list)))))
+;; line-list)
+
+;; ;; Add entries for "." and ".." if they're checked-out.
+;; ;;
+;; (let* ((entry ".")
+;; (path (expand-file-name (concat true-directory entry))))
+;; (if (clearcase-fprop-checked-out path)
+;; (setq checkout-list (cons path checkout-list))))
+;; (let* ((entry "..")
+;; (path (expand-file-name (concat true-directory entry))))
+;; (if (clearcase-fprop-checked-out path)
+;; (setq checkout-list (cons path checkout-list))))
+
+;; (message "Listing ClearCase checkouts...done")
+
+;; ;; Return the result.
+;; ;;
+;; checkout-list)))
+
+;; (defun clearcase-dired-list-hijacks (directory)
+;; "Returns a list of files hijacked to the current view in DIRECTORY."
+
+;; ;; Don't bother looking for hijacks in;
+;; ;; - a history-mode listing
+;; ;; - a in view-private directory
+;; ;; - a dynamic view
+;; ;;
+;; (let* ((true-directory (file-truename directory))
+;; (viewtag (clearcase-fprop-viewtag true-directory)))
+
+;; (if (and viewtag
+;; (not (clearcase-vxpath-p directory))
+;; (not (eq 'view-private-object (clearcase-fprop-mtype directory)))
+;; (clearcase-file-would-be-in-snapshot-p true-directory))
+
+;; (let* ((ignore (message "Listing ClearCase hijacks..."))
+
+;; (true-directory (file-truename directory))
+
+;; ;; Form the command:
+;; ;;
+;; (cmd (list
+;; "ls"
+
+;; ;; Give the directory as an argument so all names will be
+;; ;; fullpaths. For some reason ClearCase adds an extra slash
+;; ;; if you leave the trailing slash on the directory, so we
+;; ;; need to remove it.
+;; ;;
+;; (clearcase-path-native (directory-file-name true-directory))))
+
+;; ;; Capture the output:
+;; ;;
+;; (string (clearcase-path-canonicalise-slashes
+;; (apply 'clearcase-ct-cleartool-cmd cmd)))
+
+;; ;; Split the output at the newlines:
+;; ;;
+;; (line-list (clearcase-utl-split-string-at-char string ?\n))
+
+;; (hijack-list nil))
+
+;; (mapcar (function
+;; (lambda (line)
+;; (if (string-match "^\\([^ @]+\\)@@[^ ]+ \\[hijacked\\].*" line)
+;; (setq hijack-list (cons (substring line
+;; (match-beginning 1)
+;; (match-end 1))
+;; hijack-list)))))
+;; line-list)
+
+;; (message "Listing ClearCase hijacks...done")
+
+;; ;; Return the result.
+;; ;;
+;; hijack-list))))
+
+;;}}}
+
+(defun clearcase-dired-list-modified-files (directory)
+ "Returns a pair of lists of files (checkouts . hijacks) to the current view in DIRECTORY."
+
+ ;; Don't bother looking for hijacks in;
+ ;; - a history-mode listing
+ ;; - a in view-private directory
+ ;; - a dynamic view
+ ;;
+ (let* ((true-directory (file-truename directory))
+ (viewtag (clearcase-fprop-viewtag true-directory))
+ (snapshot (clearcase-file-would-be-in-snapshot-p true-directory))
+ (result '(() ())))
+
+ (if (and viewtag
+ (not (clearcase-vxpath-p directory))
+ (not (eq 'view-private-object (clearcase-fprop-mtype directory))))
+
+ (let* ((ignore (message "Listing ClearCase modified files..."))
+
+ (true-directory (file-truename directory))
+
+ ;; Form the command:
+ ;;
+ (cmd (list
+ "ls"
+
+ ;; Give the directory as an argument so all names will be
+ ;; fullpaths. For some reason ClearCase adds an extra slash
+ ;; if you leave the trailing slash on the directory, so we
+ ;; need to remove it.
+ ;;
+ (clearcase-path-native (directory-file-name true-directory))))
+
+ ;; Capture the output:
+ ;;
+ (string (clearcase-path-canonicalise-slashes
+ (apply 'clearcase-ct-cleartool-cmd cmd)))
+
+ ;; Split the output at the newlines:
+ ;;
+ (line-list (clearcase-utl-split-string-at-char string ?\n))
+
+ (hijack-list nil)
+ (checkout-list nil))
+
+ (mapcar (function
+ (lambda (line)
+ (if (string-match "^\\([^ @]+\\)@@[^ ]+ \\[hijacked\\].*" line)
+ (setq hijack-list (cons (substring line
+ (match-beginning 1)
+ (match-end 1))
+ hijack-list)))
+ (if (string-match "^\\([^ @]+\\)@@.+CHECKEDOUT from .*" line)
+ (setq checkout-list (cons (substring line
+ (match-beginning 1)
+ (match-end 1))
+ checkout-list)))))
+ line-list)
+
+ (message "Listing ClearCase modified files...done")
+
+ ;; Return the result.
+ ;;
+ (setq result (list checkout-list hijack-list))))
+ result))
+
+;;}}}
+
+;;}}}
+
+;; For ClearCase Dired Minor Mode
+;;
+(defvar clearcase-dired-mode nil)
+(set-default 'clearcase-dired-mode nil)
+(make-variable-buffer-local 'clearcase-dired-mode)
+
+;; Tell Emacs about this new kind of minor mode
+;;
+(if (not (assoc 'clearcase-dired-mode minor-mode-alist))
+ (setq minor-mode-alist (cons '(clearcase-dired-mode clearcase-dired-mode)
+ minor-mode-alist)))
+
+;; For now we override the bindings for VC Minor Mode with ClearCase Dired
+;; Minor Mode bindings.
+;;
+(defvar clearcase-dired-mode-map (make-sparse-keymap))
+(defvar clearcase-dired-prefix-map (make-sparse-keymap))
+(define-key clearcase-dired-mode-map "\C-xv" clearcase-dired-prefix-map)
+
+(define-key clearcase-dired-prefix-map "b" 'clearcase-browse-vtree-dired-file)
+(define-key clearcase-dired-prefix-map "c" 'clearcase-uncheckout-dired-files)
+(define-key clearcase-dired-prefix-map "e" 'clearcase-edcs-edit)
+(define-key clearcase-dired-prefix-map "i" 'clearcase-mkelem-dired-files)
+(define-key clearcase-dired-prefix-map "g" 'clearcase-annotate-dired-file)
+(define-key clearcase-dired-prefix-map "l" 'clearcase-list-history-dired-file)
+(define-key clearcase-dired-prefix-map "m" 'clearcase-mkbrtype)
+(define-key clearcase-dired-prefix-map "u" 'clearcase-uncheckout-dired-files)
+(define-key clearcase-dired-prefix-map "v" 'clearcase-next-action-dired-files)
+(define-key clearcase-dired-prefix-map "w" 'clearcase-what-rule-dired-file)
+(define-key clearcase-dired-prefix-map "=" 'clearcase-diff-pred-dired-file)
+(define-key clearcase-dired-prefix-map "~" 'clearcase-version-other-window)
+(define-key clearcase-dired-prefix-map "?" 'clearcase-describe-dired-file)
+
+;; To avoid confusion, we prevent VC Mode from being active at all by
+;; undefining its keybindings for which ClearCase Mode doesn't yet have an
+;; analogue.
+;;
+(define-key clearcase-dired-prefix-map "a" 'undefined) ;; vc-update-change-log
+(define-key clearcase-dired-prefix-map "d" 'undefined) ;; vc-directory
+(define-key clearcase-dired-prefix-map "h" 'undefined) ;; vc-insert-headers
+(define-key clearcase-dired-prefix-map "m" 'undefined) ;; vc-merge
+(define-key clearcase-dired-prefix-map "r" 'undefined) ;; vc-retrieve-snapshot
+(define-key clearcase-dired-prefix-map "s" 'undefined) ;; vc-create-snapshot
+(define-key clearcase-dired-prefix-map "t" 'undefined) ;; vc-dired-toggle-terse-mode
+
+;; Associate the map and the minor mode
+;;
+(or (not (boundp 'minor-mode-map-alist))
+ (assq 'clearcase-dired-mode (symbol-value 'minor-mode-map-alist))
+ (setq minor-mode-map-alist
+ (cons (cons 'clearcase-dired-mode clearcase-dired-mode-map)
+ minor-mode-map-alist)))
+
+(defun clearcase-dired-mode (&optional arg)
+ "The augmented Dired minor mode used in ClearCase directory buffers.
+All Dired commands operate normally. Users with checked-out files
+are listed in place of the file's owner and group. Keystrokes bound to
+ClearCase Mode commands will execute as though they had been called
+on a buffer attached to the file named in the current Dired buffer line."
+
+ (interactive "P")
+
+ ;; Behave like a proper minor-mode.
+ ;;
+ (setq clearcase-dired-mode
+ (if (interactive-p)
+ (if (null arg)
+ (not clearcase-dired-mode)
+
+ ;; Check if the numeric arg is positive.
+ ;;
+ (> (prefix-numeric-value arg) 0))
+
+ ;; else
+ ;; Use the car if it's a list.
+ ;;
+ (if (consp arg)
+ (setq arg (car arg)))
+
+ (if (symbolp arg)
+ (if (null arg)
+ (not clearcase-dired-mode) ;; toggle mode switch
+ (not (eq '- arg))) ;; True if symbol is not '-
+
+ ;; else
+ ;; assume it's a number and check that.
+ ;;
+ (> arg 0))))
+
+ (if (not (eq major-mode 'dired-mode))
+ (setq clearcase-dired-mode nil))
+
+ (if (and clearcase-dired-mode clearcase-dired-highlight)
+ (clearcase-dired-reformat-buffer))
+
+ (if clearcase-dired-mode
+ (easy-menu-add clearcase-dired-menu 'clearcase-dired-mode-map))
+ )
+
+;;}}}
+
+;;{{{ Major Mode: for editing comments.
+
+;; The major mode function.
+;;
+(defun clearcase-comment-mode ()
+ "Major mode for editing comments for ClearCase.
+
+These bindings are added to the global keymap when you enter this mode:
+
+\\[clearcase-next-action-current-buffer] perform next logical version-control operation on current file
+\\[clearcase-mkelem-current-buffer] mkelem the current file
+\\[clearcase-toggle-read-only] like next-action, but won't create elements
+\\[clearcase-list-history-current-buffer] display change history of current file
+\\[clearcase-uncheckout-current-buffer] cancel checkout in buffer
+\\[clearcase-diff-pred-current-buffer] show diffs between file versions
+\\[clearcase-version-other-window] visit old version in another window
+
+While you are entering a comment for a version, the following
+additional bindings will be in effect.
+
+\\[clearcase-comment-finish] proceed with check in, ending comment
+
+Whenever you do a checkin, your comment is added to a ring of
+saved comments. These can be recalled as follows:
+
+\\[clearcase-comment-next] replace region with next message in comment ring
+\\[clearcase-comment-previous] replace region with previous message in comment ring
+\\[clearcase-comment-search-reverse] search backward for regexp in the comment ring
+\\[clearcase-comment-search-forward] search backward for regexp in the comment ring
+
+Entry to the clearcase-comment-mode calls the value of text-mode-hook, then
+the value of clearcase-comment-mode-hook.
+
+Global user options:
+ clearcase-initial-mkelem-comment If non-nil, require user to enter a change
+ comment upon first checkin of the file.
+
+ clearcase-suppress-confirm Suppresses some confirmation prompts,
+ notably for reversions.
+
+ clearcase-command-messages If non-nil, display run messages from the
+ actual version-control utilities (this is
+ intended primarily for people hacking clearcase.el
+ itself).
+"
+ (interactive)
+
+ ;; Major modes are supposed to just (kill-all-local-variables)
+ ;; but we rely on clearcase-parent-buffer already having been set
+ ;;
+ ;;(let ((parent clearcase-parent-buffer))
+ ;; (kill-all-local-variables)
+ ;; (set (make-local-variable 'clearcase-parent-buffer) parent))
+
+ (setq major-mode 'clearcase-comment-mode)
+ (setq mode-name "ClearCase/Comment")
+
+ (set-syntax-table text-mode-syntax-table)
+ (use-local-map clearcase-comment-mode-map)
+ (setq local-abbrev-table text-mode-abbrev-table)
+
+ (make-local-variable 'clearcase-comment-operands)
+ (make-local-variable 'clearcase-comment-ring-index)
+
+ (set-buffer-modified-p nil)
+ (setq buffer-file-name nil)
+ (run-hooks 'text-mode-hook 'clearcase-comment-mode-hook))
+
+;; The keymap.
+;;
+(defvar clearcase-comment-mode-map nil)
+(if clearcase-comment-mode-map
+ nil
+ (setq clearcase-comment-mode-map (make-sparse-keymap))
+ (define-key clearcase-comment-mode-map "\M-n" 'clearcase-comment-next)
+ (define-key clearcase-comment-mode-map "\M-p" 'clearcase-comment-previous)
+ (define-key clearcase-comment-mode-map "\M-r" 'clearcase-comment-search-reverse)
+ (define-key clearcase-comment-mode-map "\M-s" 'clearcase-comment-search-forward)
+ (define-key clearcase-comment-mode-map "\C-c\C-c" 'clearcase-comment-finish)
+ (define-key clearcase-comment-mode-map "\C-x\C-s" 'clearcase-comment-save)
+ (define-key clearcase-comment-mode-map "\C-x\C-q" 'clearcase-comment-num-num-error))
+
+;; Constants.
+;;
+(defconst clearcase-comment-maximum-ring-size 32
+ "Maximum number of saved comments in the comment ring.")
+
+;; Variables.
+;;
+(defvar clearcase-comment-entry-mode nil)
+(defvar clearcase-comment-operation nil)
+(defvar clearcase-comment-operands)
+(defvar clearcase-comment-ring nil)
+(defvar clearcase-comment-ring-index nil)
+(defvar clearcase-comment-last-match nil)
+(defvar clearcase-comment-window-config nil)
+
+;; In several contexts, this is a local variable that points to the buffer for
+;; which it was made (either a file, or a ClearCase dired buffer).
+;;
+(defvar clearcase-parent-buffer nil)
+(defvar clearcase-parent-buffer-name nil)
+
+;;{{{ Commands and functions
+
+(defun clearcase-comment-start-entry (uniquifier
+ prompt
+ continuation
+ operands
+ &optional parent-buffer comment-seed)
+
+ "Accept a comment by popping up a clearcase-comment-mode buffer
+with a name derived from UNIQUIFIER, and emitting PROMPT in the minibuffer.
+Set the continuation on close to CONTINUATION, which should be apply-ed to a list
+formed by appending OPERANDS and the comment-string.
+
+Optional 5th argument specifies a PARENT-BUFFER to return to when the operation
+is complete.
+
+Optional 6th argument specifies a COMMENT-SEED to insert in the comment buffer for
+the user to edit."
+
+ (let ((comment-buffer (get-buffer-create (format "*clearcase-comment-%s*" uniquifier)))
+ (old-window-config (current-window-configuration))
+ (parent (or parent-buffer
+ (current-buffer))))
+ (pop-to-buffer comment-buffer)
+
+ ;; Record in buffer-local variables information sufficient to restore
+ ;; window context.
+ ;;
+ (set (make-local-variable 'clearcase-comment-window-config) old-window-config)
+ (set (make-local-variable 'clearcase-parent-buffer) parent)
+
+ (clearcase-comment-mode)
+ (setq clearcase-comment-operation continuation)
+ (setq clearcase-comment-operands operands)
+ (if comment-seed
+ (insert comment-seed))
+ (message "%s Type C-c C-c when done." prompt)))
+
+
+(defun clearcase-comment-cleanup ()
+ ;; Make sure it ends with newline
+ ;;
+ (goto-char (point-max))
+ (if (not (bolp))
+ (newline))
+
+ ;; Remove useless whitespace.
+ ;;
+ (goto-char (point-min))
+ (while (re-search-forward "[ \t]+$" nil t)
+ (replace-match ""))
+
+ ;; Remove trailing newlines, whitespace.
+ ;;
+ (goto-char (point-max))
+ (skip-chars-backward " \n\t")
+ (delete-region (point) (point-max)))
+
+(defun clearcase-comment-finish ()
+ "Complete the operation implied by the current comment."
+ (interactive)
+
+ ;;Clean and record the comment in the ring.
+ ;;
+ (let ((comment-buffer (current-buffer)))
+ (clearcase-comment-cleanup)
+
+ (if (null clearcase-comment-ring)
+ (setq clearcase-comment-ring (make-ring clearcase-comment-maximum-ring-size)))
+ (ring-insert clearcase-comment-ring (buffer-string))
+
+ ;; Perform the operation on the operands.
+ ;;
+ (if clearcase-comment-operation
+ (save-excursion
+ (apply clearcase-comment-operation
+ (append clearcase-comment-operands (list (buffer-string)))))
+ (error "No comment operation is pending"))
+
+ ;; Return to "parent" buffer of this operation.
+ ;; Remove comment window.
+ ;;
+ (let ((old-window-config clearcase-comment-window-config))
+ (pop-to-buffer clearcase-parent-buffer)
+ (delete-windows-on comment-buffer)
+ (kill-buffer comment-buffer)
+ (if old-window-config (set-window-configuration old-window-config)))))
+
+(defun clearcase-comment-save-comment-for-buffer (comment buffer)
+ (save-excursion
+ (set-buffer buffer)
+ (let ((file (buffer-file-name)))
+ (if (clearcase-fprop-checked-out file)
+ (progn
+ (clearcase-ct-do-cleartool-command "chevent"
+ file
+ comment
+ (list "-replace"))
+ (clearcase-fprop-set-comment file comment))
+ (error "Can't change comment of checked-in version with this interface")))))
+
+(defun clearcase-comment-save ()
+ "Save the currently entered comment"
+ (interactive)
+ (let ((comment-string (buffer-string))
+ (parent-buffer clearcase-parent-buffer))
+ (if (not (buffer-modified-p))
+ (message "(No changes need to be saved)")
+ (progn
+ (save-excursion
+ (set-buffer parent-buffer)
+ (clearcase-comment-save-comment-for-buffer comment-string parent-buffer))
+
+ (set-buffer-modified-p nil)))))
+
+(defun clearcase-comment-num-num-error ()
+ (interactive)
+ (message "Perhaps you wanted to type C-c C-c instead?"))
+
+;; Code for the comment ring.
+;;
+(defun clearcase-comment-next (arg)
+ "Cycle forwards through comment history."
+ (interactive "*p")
+ (clearcase-comment-previous (- arg)))
+
+(defun clearcase-comment-previous (arg)
+ "Cycle backwards through comment history."
+ (interactive "*p")
+ (let ((len (ring-length clearcase-comment-ring)))
+ (cond ((or (not len) (<= len 0))
+ (message "Empty comment ring")
+ (ding))
+ (t
+ (erase-buffer)
+
+ ;; Initialize the index on the first use of this command so that the
+ ;; first M-p gets index 0, and the first M-n gets index -1.
+ ;;
+ (if (null clearcase-comment-ring-index)
+ (setq clearcase-comment-ring-index
+ (if (> arg 0) -1
+ (if (< arg 0) 1 0))))
+ (setq clearcase-comment-ring-index
+ (mod (+ clearcase-comment-ring-index arg) len))
+ (message "%d" (1+ clearcase-comment-ring-index))
+ (insert (ring-ref clearcase-comment-ring clearcase-comment-ring-index))))))
+
+(defun clearcase-comment-search-forward (str)
+ "Searches forwards through comment history for substring match."
+ (interactive "sComment substring: ")
+ (if (string= str "")
+ (setq str clearcase-comment-last-match)
+ (setq clearcase-comment-last-match str))
+ (if (null clearcase-comment-ring-index)
+ (setq clearcase-comment-ring-index 0))
+ (let ((str (regexp-quote str))
+ (n clearcase-comment-ring-index))
+ (while (and (>= n 0) (not (string-match str (ring-ref clearcase-comment-ring n))))
+ (setq n (- n 1)))
+ (cond ((>= n 0)
+ (clearcase-comment-next (- n clearcase-comment-ring-index)))
+ (t (error "Not found")))))
+
+(defun clearcase-comment-search-reverse (str)
+ "Searches backwards through comment history for substring match."
+ (interactive "sComment substring: ")
+ (if (string= str "")
+ (setq str clearcase-comment-last-match)
+ (setq clearcase-comment-last-match str))
+ (if (null clearcase-comment-ring-index)
+ (setq clearcase-comment-ring-index -1))
+ (let ((str (regexp-quote str))
+ (len (ring-length clearcase-comment-ring))
+ (n (1+ clearcase-comment-ring-index)))
+ (while (and (< n len)
+ (not (string-match str (ring-ref clearcase-comment-ring n))))
+ (setq n (+ n 1)))
+ (cond ((< n len)
+ (clearcase-comment-previous (- n clearcase-comment-ring-index)))
+ (t (error "Not found")))))
+
+;;}}}
+
+;;}}}
+
+;;{{{ Major Mode: for editing config-specs.
+
+;; The major mode function.
+;;
+(defun clearcase-edcs-mode ()
+ (interactive)
+ (set-syntax-table text-mode-syntax-table)
+ (use-local-map clearcase-edcs-mode-map)
+ (setq major-mode 'clearcase-edcs-mode)
+ (setq mode-name "ClearCase/edcs")
+ (make-variable-buffer-local 'clearcase-parent-buffer)
+ (set-buffer-modified-p nil)
+ (setq buffer-file-name nil)
+ (run-hooks 'text-mode-hook 'clearcase-edcs-mode-hook))
+
+;; The keymap.
+;;
+(defvar clearcase-edcs-mode-map nil)
+(if clearcase-edcs-mode-map
+ nil
+ (setq clearcase-edcs-mode-map (make-sparse-keymap))
+ (define-key clearcase-edcs-mode-map "\C-c\C-c" 'clearcase-edcs-finish)
+ (define-key clearcase-edcs-mode-map "\C-x\C-s" 'clearcase-edcs-save))
+
+;; Variables.
+;;
+(defvar clearcase-edcs-tag-name nil
+ "Name of view tag which is currently being edited")
+
+(defvar clearcase-edcs-tag-history ()
+ "History of view tags used in clearcase-edcs-edit")
+
+;;{{{ Commands
+
+(defun clearcase-edcs-edit (tag-name)
+ "Edit a ClearCase configuration specification"
+
+ (interactive
+ (let ((vxname (clearcase-fprop-viewtag default-directory)))
+ (if clearcase-complete-viewtags
+ (list (directory-file-name
+ (completing-read "View Tag: "
+ (clearcase-viewtag-all-viewtags-obarray)
+ nil
+ ;;'fascist
+ nil
+ vxname
+ 'clearcase-edcs-tag-history)))
+ (read-string "View Tag: "))))
+
+ (let ((start (current-buffer))
+ (buffer-name (format "*clearcase-config-spec-%s*" tag-name)))
+ (kill-buffer (get-buffer-create buffer-name))
+ (pop-to-buffer (get-buffer-create buffer-name))
+ (auto-save-mode auto-save-default)
+ (erase-buffer)
+ (insert (clearcase-ct-cleartool-cmd "catcs" "-tag" tag-name))
+ (goto-char (point-min))
+ (re-search-forward "^[^#\n]" nil 'end)
+ (beginning-of-line)
+ (clearcase-edcs-mode)
+ (setq clearcase-parent-buffer start)
+ (make-local-variable 'clearcase-edcs-tag-name)
+ (setq clearcase-edcs-tag-name tag-name)))
+
+(defun clearcase-edcs-save ()
+ (interactive)
+ (if (not (buffer-modified-p))
+ (message "Configuration not changed since last saved")
+
+ (message "Setting configuration for %s..." clearcase-edcs-tag-name)
+ (clearcase-with-tempfile
+ cspec-text
+ (write-region (point-min) (point-max) cspec-text nil 'dont-mention-it)
+ (let ((ret (clearcase-ct-cleartool-cmd "setcs"
+ "-tag"
+ clearcase-edcs-tag-name
+ (clearcase-path-native cspec-text))))
+
+ ;; nyi: we could be smarter and retain viewtag info and perhaps some
+ ;; other info. For now invalidate all cached file property info.
+ ;;
+ (clearcase-fprop-clear-all-properties)
+
+ (set-buffer-modified-p nil)
+ (message "Setting configuration for %s...done"
+ clearcase-edcs-tag-name)))))
+
+(defun clearcase-edcs-finish ()
+ (interactive)
+ (let ((old-buffer (current-buffer)))
+ (clearcase-edcs-save)
+ (bury-buffer nil)
+ (kill-buffer old-buffer)))
+
+;;}}}
+
+;;}}}
+
+;;{{{ View browser
+
+;; nyi: Just an idea now.
+;; Be able to present a selection of views at various times
+;; - show me current file in other view
+;; - top-level browse operation
+
+;; clearcase-viewtag-started-viewtags gives us the dynamic views that are mounted.
+
+;; How to find local snapshots ?
+
+;; How to find drive-letter mount points for view on NT ?
+;; - parse "subst" output
+
+;;}}}
+
+;;{{{ Commands
+
+;;{{{ Hijack/unhijack
+
+(defun clearcase-hijack-current-buffer ()
+ "Hijack the file in the current buffer."
+ (interactive)
+ (clearcase-hijack buffer-file-name))
+
+(defun clearcase-hijack-dired-files ()
+ "Hijack the selected files."
+ (interactive)
+ (clearcase-hijack-seq (dired-get-marked-files)))
+
+(defun clearcase-unhijack-current-buffer ()
+ "Unhijack the file in the current buffer."
+ (interactive)
+ (clearcase-unhijack buffer-file-name))
+
+(defun clearcase-unhijack-dired-files ()
+ "Hijack the selected files."
+ (interactive)
+ (clearcase-unhijack-seq (dired-get-marked-files)))
+
+;;}}}
+
+;;{{{ Annotate
+
+(defun clearcase-annotate-file (file)
+ (let ((relative-name (file-relative-name file)))
+ (message "Annotating %s ..." relative-name)
+ (clearcase-with-tempfile
+ annotation-file
+ (clearcase-ct-do-cleartool-command "annotate"
+ file
+ 'unused
+ (list "-nco"
+ "-out"
+ annotation-file))
+ (clearcase-utl-populate-and-view-buffer
+ "*clearcase-annotate*"
+ nil
+ (function
+ (lambda ()
+ (insert-file-contents annotation-file)))))
+ (message "Annotating %s ...done" relative-name)))
+
+(defun clearcase-annotate-current-buffer ()
+ (interactive)
+ (clearcase-annotate-file buffer-file-name))
+
+(defun clearcase-annotate-dired-file ()
+ "Annotate the selected file."
+ (interactive)
+ (clearcase-annotate-file (dired-get-filename)))
+
+;;}}}
+
+;;{{{ nyi: Find checkouts
+
+;; NYI: Enhance this:
+;; - group by:
+;; - activity name
+;; - checkout comment
+;; - permit unco/checkin
+;;
+(defun clearcase-find-checkouts-in-current-view ()
+ "Find the checkouts in all vobs in the current view."
+ (interactive)
+ (let ((viewtag (clearcase-fprop-viewtag default-directory))
+ (dir default-directory))
+ (if viewtag
+ (let* ((ignore (message "Finding checkouts..."))
+ (text (clearcase-ct-blocking-call "lsco"
+ "-cview"
+ "-avobs"
+ "-short")))
+ (if (zerop (length text))
+ (message "No checkouts found")
+ (progn
+ (message "Finding checkouts...done")
+
+ (clearcase-utl-populate-and-view-buffer
+ "*clearcase*"
+ (list text)
+ (function (lambda (s)
+ (insert s))))))))))
+
+;;}}}
+
+;;{{{ UCM operations
+
+;;{{{ Make activity
+
+(defun clearcase-read-new-activity-name ()
+ "Read the name of a new activity from the minibuffer.
+Return nil if the empty string is entered."
+
+ ;; nyi: Probably should check that the activity doesn't already exist.
+ ;;
+ (let ((entered-name (read-string "Activity name (optional): " )))
+ (if (not (zerop (length entered-name)))
+ entered-name
+ nil)))
+
+(defun clearcase-read-mkact-args ()
+ "Read the name and headline arguments for clearcase-ucm-mkact-current-dir
+from the minibuffer."
+
+ (let ((name nil)
+ (headline ""))
+ (if clearcase-prompt-for-activity-names
+ (setq name (clearcase-read-new-activity-name)))
+ (setq headline (read-string "Activity headline: " ))
+ (list name headline)))
+
+(defun clearcase-make-internally-named-activity (stream-name comment-file)
+ "Make a new activity in STREAM-NAME with creation comment in COMMENT-FILE,
+and use an internally-generated name for the activity."
+
+ (let ((ret
+ (if clearcase-set-to-new-activity
+ (clearcase-ct-blocking-call "mkact"
+ "-cfile" (clearcase-path-native comment-file)
+ "-in" stream-name
+ "-force")
+ (clearcase-ct-blocking-call "mkact"
+ "-nset"
+ "-cfile" (clearcase-path-native comment-file)
+ "-in" stream-name
+ "-nset"
+ "-force"))))
+ (if (string-match "Created activity \"\\([^\"]+\\)\"" ret)
+ (substring ret (match-beginning 1) (match-end 1))
+ (error "Failed to create activity: %s" ret))))
+
+(defun clearcase-ucm-mkact-current-dir (name headline &optional comment)
+
+ "Make an activity with NAME and HEADLINE and optional COMMENT, in the stream
+associated with the view associated with the current directory."
+
+ (interactive (clearcase-read-mkact-args))
+ (let* ((viewtag (clearcase-fprop-viewtag default-directory))
+ (stream (clearcase-vprop-stream viewtag))
+ (pvob (clearcase-vprop-pvob viewtag)))
+ (if (not (clearcase-vprop-ucm viewtag))
+ (error "View %s is not a UCM view" viewtag))
+ (if (null stream)
+ (error "View %s has no stream" viewtag))
+ (if (null stream)
+ (error "View %s has no PVOB" viewtag))
+
+ (if (null comment)
+ ;; If no comment supplied, go and get one..
+ ;;
+ (progn
+ (clearcase-comment-start-entry (format "new-activity-%d" (random))
+ "Enter comment for new activity."
+ 'clearcase-ucm-mkact-current-dir
+ (list name headline)))
+ ;; ...else do the operation.
+ ;;
+ (message "Making activity...")
+ (clearcase-with-tempfile
+ comment-file
+ (write-region comment nil comment-file nil 'noprint)
+ (let ((qualified-stream (format "%s@%s" stream pvob)))
+ (if (stringp name)
+ (if clearcase-set-to-new-activity
+ (clearcase-ct-blocking-call "mkact"
+ "-cfile" (clearcase-path-native comment-file)
+ "-headline" headline
+ "-in" qualified-stream
+ "-force"
+ name)
+ (clearcase-ct-blocking-call "mkact"
+ "-nset"
+ "-cfile" (clearcase-path-native comment-file)
+ "-headline" headline
+ "-in" qualified-stream
+ "-force"
+ name))
+ (progn
+ ;; If no name was provided we do the creation in two steps:
+ ;; mkact -force
+ ;; chact -headline
+ ;; to make sure we get preferred internally generated activity
+ ;; name of the form "activityNNN.MMM" rather than some horrible
+ ;; concoction based on the headline.
+ ;;
+ (let ((name (clearcase-make-internally-named-activity qualified-stream comment-file)))
+ (clearcase-ct-blocking-call "chact"
+ "-headline" headline
+ name))))))
+
+ ;; Flush the activities for this view so they'll get refreshed when needed.
+ ;;
+ (clearcase-vprop-flush-activities viewtag)
+
+ (message "Making activity...done"))))
+
+;;}}}
+
+;;{{{ Set activity
+
+(defun clearcase-ucm-filter-out-rebases (activities)
+ (if (not clearcase-hide-rebase-activities)
+ activities
+ (clearcase-utl-list-filter
+ (function
+ (lambda (activity)
+ (let ((id (car activity)))
+ (not (string-match clearcase-rebase-id-regexp id)))))
+ activities)))
+
+(defun clearcase-ucm-set-activity-current-dir ()
+ (interactive)
+ (let* ((viewtag (clearcase-fprop-viewtag default-directory)))
+ (if (not (clearcase-vprop-ucm viewtag))
+ (error "View %s is not a UCM view" viewtag))
+ ;; Filter out the rebases here if the user doesn't want to see them.
+ ;;
+ (let ((activities (clearcase-ucm-filter-out-rebases (clearcase-vprop-activities viewtag))))
+ (if (null activities)
+ (error "View %s has no activities" viewtag))
+ (clearcase-ucm-make-selection-window (format "*clearcase-activity-select-%s*" viewtag)
+ (mapconcat
+ (function
+ (lambda (activity)
+ (let ((id (car activity))
+ (title (cdr activity)))
+ (format "%s\t%s" id title))))
+ activities
+ "\n")
+ 'clearcase-ucm-activity-selection-interpreter
+ 'clearcase-ucm-set-activity
+ (list viewtag)))))
+
+(defun clearcase-ucm-activity-selection-interpreter ()
+ "Extract the activity name from the buffer at point"
+ (if (looking-at "^\\(.*\\)\t")
+ (let ((activity-name (buffer-substring (match-beginning 1)
+ (match-end 1))))
+ activity-name)
+ (error "No activity on this line")))
+
+(defun clearcase-ucm-set-activity-none-current-dir ()
+ (interactive)
+ (let* ((viewtag (clearcase-fprop-viewtag default-directory)))
+ (if (not (clearcase-vprop-ucm viewtag))
+ (error "View %s is not a UCM view" viewtag))
+ (clearcase-ucm-set-activity viewtag nil)))
+
+(defun clearcase-ucm-set-activity (viewtag activity-name)
+ (if activity-name
+ ;; Set an activity
+ ;;
+ (progn
+ (message "Setting activity...")
+ (let ((qualified-activity-name (if (string-match "@" activity-name)
+ activity-name
+ (concat activity-name "@" (clearcase-vprop-pvob viewtag)))))
+ (clearcase-ct-blocking-call "setactivity" "-nc" "-view"
+ viewtag
+ (if qualified-activity-name
+ qualified-activity-name
+ "-none")))
+ ;; Update cache
+ ;;
+ (clearcase-vprop-set-current-activity viewtag activity-name)
+ (message "Setting activity...done"))
+
+ ;; Set NO activity
+ ;;
+ (message "Unsetting activity...")
+ (clearcase-ct-blocking-call "setactivity"
+ "-nc"
+ "-view" viewtag
+ "-none")
+ ;; Update cache
+ ;;
+ (clearcase-vprop-set-current-activity viewtag nil)
+ (message "Unsetting activity...done")))
+
+;;}}}
+
+;;{{{ Show current activity
+
+(defun clearcase-ucm-describe-current-activity ()
+ (interactive)
+ (let* ((viewtag (clearcase-fprop-viewtag default-directory)))
+ (if (not viewtag)
+ (error "Not in a view"))
+ (if (not (clearcase-vprop-ucm viewtag))
+ (error "View %s is not a UCM view" viewtag))
+ (let ((pvob (clearcase-vprop-pvob viewtag))
+ (current-activity (clearcase-vprop-current-activity viewtag)))
+ (if (not current-activity)
+ (message "No activity set")
+ (let ((text (clearcase-ct-blocking-call "desc"
+ (concat "activity:"
+ current-activity
+ "@"
+ pvob))))
+ (if (not (zerop (length text)))
+ (clearcase-utl-populate-and-view-buffer
+ "*clearcase*"
+ (list text)
+ (function (lambda (s)
+ (insert s))))))))))
+;;}}}
+
+;;}}}
+
+;;{{{ Next-action
+
+(defun clearcase-next-action-current-buffer ()
+ "Do the next logical operation on the current file.
+Operations include mkelem, checkout, checkin, uncheckout"
+ (interactive)
+ (clearcase-next-action buffer-file-name))
+
+(defun clearcase-next-action-dired-files ()
+ "Do the next logical operation on the marked files.
+Operations include mkelem, checkout, checkin, uncheckout.
+If all the files are not in an equivalent state, an error is raised."
+
+ (interactive)
+ (clearcase-next-action-seq (dired-get-marked-files)))
+
+(defun clearcase-next-action (file)
+ (let ((action (clearcase-compute-next-action file)))
+ (cond
+
+ ((eq action 'mkelem)
+ (clearcase-commented-mkelem file))
+
+ ((eq action 'checkout)
+ (clearcase-commented-checkout file))
+
+ ((eq action 'uncheckout)
+ (if (yes-or-no-p "Checked-out file appears unchanged. Cancel checkout ? ")
+ (clearcase-uncheckout file)))
+
+ ((eq action 'illegal-checkin)
+ (error "This file is checked out by someone else: %s" (clearcase-fprop-user file)))
+
+ ((eq action 'checkin)
+ (clearcase-commented-checkin file))
+
+ (t
+ (error "Can't compute suitable next ClearCase action for file %s" file)))))
+
+(defun clearcase-next-action-seq (files)
+ "Do the next logical operation on the sequence of FILES."
+
+ ;; Check they're all in the same state.
+ ;;
+ (let ((actions (mapcar (function clearcase-compute-next-action) files)))
+ (if (not (clearcase-utl-elts-are-eq actions))
+ (error "Marked files are not all in the same state"))
+ (let ((action (car actions)))
+ (cond
+
+ ((eq action 'mkelem)
+ (clearcase-commented-mkelem-seq files))
+
+ ((eq action 'checkout)
+ (clearcase-commented-checkout-seq files))
+
+ ((eq action 'uncheckout)
+ (if (yes-or-no-p "Checked-out files appears unchanged. Cancel checkouts ? ")
+ (clearcase-uncheckout-seq files)))
+
+ ((eq action 'illegal-checkin)
+ (error "These files are checked out by someone else; will no checkin"))
+
+ ((eq action 'checkin)
+ (clearcase-commented-checkin-seq files))
+
+ (t
+ (error "Can't compute suitable next ClearCase action for marked files"))))))
+
+(defun clearcase-compute-next-action (file)
+ "Compute the next logical action on FILE."
+
+ (cond
+ ;; nyi: other cases to consider later:
+ ;;
+ ;; - file is unreserved
+ ;; - file is not mastered
+
+ ;; Case 1: it is not yet an element
+ ;; ==> mkelem
+ ;;
+ ((clearcase-file-ok-to-mkelem file)
+ 'mkelem)
+
+ ;; Case 2: file is not checked out
+ ;; ==> checkout
+ ;;
+ ((clearcase-file-ok-to-checkout file)
+ 'checkout)
+
+ ;; Case 3: file is checked-out but not modified in buffer or disk
+ ;; ==> offer to uncheckout
+ ;;
+ ((and (clearcase-file-ok-to-uncheckout file)
+ (not (file-directory-p file))
+ (not (buffer-modified-p))
+ (not (clearcase-file-appears-modified-since-checkout-p file)))
+ 'uncheckout)
+
+ ;; Case 4: file is checked-out but by somebody else using this view.
+ ;; ==> refuse to checkin
+ ;;
+ ;; This is not reliable on some Windows installations where a user is known
+ ;; as "esler" on Unix and the ClearCase server, and "ESLER" on the Windows
+ ;; client.
+ ;;
+ ((and (not clearcase-on-mswindows)
+ (clearcase-fprop-checked-out file)
+ (not (string= (user-login-name)
+ (clearcase-fprop-user file))))
+ 'illegal-checkin)
+
+ ;; Case 5: user has checked-out the file
+ ;; ==> check it in
+ ;;
+ ((clearcase-file-ok-to-checkin file)
+ 'checkin)
+
+ (t
+ nil)))
+
+;;}}}
+
+;;{{{ Mkelem
+
+(defun clearcase-mkelem-current-buffer ()
+ "Make the current file into a ClearCase element."
+ (interactive)
+
+ ;; Watch out for new buffers of size 0: the corresponding file
+ ;; does not exist yet, even though buffer-modified-p is nil.
+ ;;
+ (if (and (not (buffer-modified-p))
+ (zerop (buffer-size))
+ (not (file-exists-p buffer-file-name)))
+ (set-buffer-modified-p t))
+
+ (clearcase-commented-mkelem buffer-file-name))
+
+(defun clearcase-mkelem-dired-files ()
+ "Make the selected files into ClearCase elements."
+ (interactive)
+ (clearcase-commented-mkelem-seq (dired-get-marked-files)))
+
+;;}}}
+
+;;{{{ Checkin
+
+(defun clearcase-checkin-current-buffer ()
+ "Checkin the file in the current buffer."
+ (interactive)
+
+ ;; Watch out for new buffers of size 0: the corresponding file
+ ;; does not exist yet, even though buffer-modified-p is nil.
+ ;;
+ (if (and (not (buffer-modified-p))
+ (zerop (buffer-size))
+ (not (file-exists-p buffer-file-name)))
+ (set-buffer-modified-p t))
+
+ (clearcase-commented-checkin buffer-file-name))
+
+(defun clearcase-checkin-dired-files ()
+ "Checkin the selected files."
+ (interactive)
+ (clearcase-commented-checkin-seq (dired-get-marked-files)))
+
+(defun clearcase-dired-checkin-current-dir ()
+ (interactive)
+ (clearcase-commented-checkin (dired-current-directory)))
+
+;;}}}
+
+;;{{{ Edit checkout comment
+
+(defun clearcase-edit-checkout-comment-current-buffer ()
+ "Edit the clearcase comment for the checked-out file in the current buffer."
+ (interactive)
+ (clearcase-edit-checkout-comment buffer-file-name))
+
+(defun clearcase-edit-checkout-comment-dired-file ()
+ "Checkin the selected file."
+ (interactive)
+ (clearcase-edit-checkout-comment (dired-get-filename)))
+
+(defun clearcase-edit-checkout-comment (file &optional comment)
+ "Edit comment for FILE by popping up a buffer to accept one. If COMMENT
+is specified, save it."
+ (if (null comment)
+ ;; If no comment supplied, go and get one...
+ ;;
+ (clearcase-comment-start-entry (file-name-nondirectory file)
+ "Edit the file's check-out comment."
+ 'clearcase-edit-checkout-comment
+ (list buffer-file-name)
+ (find-file-noselect file)
+ (clearcase-fprop-comment file))
+ ;; We have a comment, save it
+ (clearcase-comment-save-comment-for-buffer comment clearcase-parent-buffer)))
+
+;;}}}
+
+;;{{{ Checkout
+
+(defun clearcase-checkout-current-buffer ()
+ "Checkout the file in the current buffer."
+ (interactive)
+ (clearcase-commented-checkout buffer-file-name))
+
+(defun clearcase-checkout-dired-files ()
+ "Checkout the selected files."
+ (interactive)
+ (clearcase-commented-checkout-seq (dired-get-marked-files)))
+
+(defun clearcase-dired-checkout-current-dir ()
+ (interactive)
+ (clearcase-commented-checkout (dired-current-directory)))
+
+;;}}}
+
+;;{{{ Uncheckout
+
+(defun clearcase-uncheckout-current-buffer ()
+ "Uncheckout the file in the current buffer."
+ (interactive)
+ (clearcase-uncheckout buffer-file-name))
+
+(defun clearcase-uncheckout-dired-files ()
+ "Uncheckout the selected files."
+ (interactive)
+ (clearcase-uncheckout-seq (dired-get-marked-files)))
+
+(defun clearcase-dired-uncheckout-current-dir ()
+ (interactive)
+ (clearcase-uncheckout (dired-current-directory)))
+
+;;}}}
+
+;;{{{ Mkbrtype
+
+(defun clearcase-mkbrtype (typename)
+ (interactive "sBranch type name: ")
+ (clearcase-commented-mkbrtype typename))
+
+;;}}}
+
+;;{{{ Describe
+
+(defun clearcase-describe-current-buffer ()
+ "Give a ClearCase description of the file in the current buffer."
+ (interactive)
+ (clearcase-describe buffer-file-name))
+
+(defun clearcase-describe-dired-file ()
+ "Describe the selected files."
+ (interactive)
+ (clearcase-describe (dired-get-filename)))
+
+;;}}}
+
+;;{{{ What-rule
+
+(defun clearcase-what-rule-current-buffer ()
+ (interactive)
+ (clearcase-what-rule buffer-file-name))
+
+(defun clearcase-what-rule-dired-file ()
+ (interactive)
+ (clearcase-what-rule (dired-get-filename)))
+
+;;}}}
+
+;;{{{ List history
+
+(defun clearcase-list-history-current-buffer ()
+ "List the change history of the current buffer in a window."
+ (interactive)
+ (clearcase-list-history buffer-file-name))
+
+(defun clearcase-list-history-dired-file ()
+ "List the change history of the current file."
+ (interactive)
+ (clearcase-list-history (dired-get-filename)))
+
+;;}}}
+
+;;{{{ Ediff
+
+(defun clearcase-ediff-pred-current-buffer ()
+ "Use Ediff to compare a version in the current buffer against its predecessor."
+ (interactive)
+ (clearcase-ediff-file-with-version buffer-file-name
+ (clearcase-fprop-predecessor-version buffer-file-name)))
+
+(defun clearcase-ediff-pred-dired-file ()
+ "Use Ediff to compare the selected version against its predecessor."
+ (interactive)
+ (let ((truename (clearcase-fprop-truename (dired-get-filename))))
+ (clearcase-ediff-file-with-version truename
+ (clearcase-fprop-predecessor-version truename))))
+
+(defun clearcase-ediff-branch-base-current-buffer()
+ "Use Ediff to compare a version in the current buffer
+against the base of its branch."
+ (interactive)
+ (clearcase-ediff-file-with-version buffer-file-name
+ (clearcase-vxpath-version-of-branch-base buffer-file-name)))
+
+(defun clearcase-ediff-branch-base-dired-file()
+ "Use Ediff to compare the selected version against the base of its branch."
+ (interactive)
+ (let ((truename (clearcase-fprop-truename (dired-get-filename))))
+ (clearcase-ediff-file-with-version truename
+ (clearcase-vxpath-version-of-branch-base truename))))
+
+(defun clearcase-ediff-named-version-current-buffer (version)
+ ;; nyi: if we're in history-mode, probably should just use
+ ;; (read-file-name)
+ ;;
+ (interactive (list (clearcase-read-version-name "Version for comparison: "
+ buffer-file-name)))
+ (clearcase-ediff-file-with-version buffer-file-name version))
+
+(defun clearcase-ediff-named-version-dired-file (version)
+ ;; nyi: if we're in history-mode, probably should just use
+ ;; (read-file-name)
+ ;;
+ (interactive (list (clearcase-read-version-name "Version for comparison: "
+ (dired-get-filename))))
+ (clearcase-ediff-file-with-version (clearcase-fprop-truename (dired-get-filename))
+ version))
+
+(defun clearcase-ediff-file-with-version (truename other-version)
+ (let ((other-vxpath (clearcase-vxpath-cons-vxpath (clearcase-vxpath-element-part truename)
+ other-version)))
+ (if (clearcase-file-is-in-mvfs-p truename)
+ (ediff-files other-vxpath truename)
+ (ediff-buffers (clearcase-vxpath-get-version-in-buffer other-vxpath)
+ (find-file-noselect truename t)))))
+
+;;}}}
+
+;;{{{ GUI diff
+
+(defun clearcase-gui-diff-pred-current-buffer ()
+ "Use GUI to compare a version in the current buffer against its predecessor."
+ (interactive)
+ (clearcase-gui-diff-file-with-version buffer-file-name
+ (clearcase-fprop-predecessor-version buffer-file-name)))
+
+(defun clearcase-gui-diff-pred-dired-file ()
+ "Use GUI to compare the selected version against its predecessor."
+ (interactive)
+ (let ((truename (clearcase-fprop-truename (dired-get-filename))))
+ (clearcase-gui-diff-file-with-version truename
+ (clearcase-fprop-predecessor-version truename))))
+
+(defun clearcase-gui-diff-branch-base-current-buffer()
+ "Use GUI to compare a version in the current buffer
+against the base of its branch."
+ (interactive)
+ (clearcase-gui-diff-file-with-version buffer-file-name
+ (clearcase-vxpath-version-of-branch-base buffer-file-name)))
+
+(defun clearcase-gui-diff-branch-base-dired-file()
+ "Use GUI to compare the selected version against the base of its branch."
+ (interactive)
+ (let ((truename (clearcase-fprop-truename (dired-get-filename))))
+ (clearcase-gui-diff-file-with-version truename
+ (clearcase-vxpath-version-of-branch-base truename))))
+
+(defun clearcase-gui-diff-named-version-current-buffer (version)
+ ;; nyi: if we're in history-mode, probably should just use
+ ;; (read-file-name)
+ ;;
+ (interactive (list (clearcase-read-version-name "Version for comparison: "
+ buffer-file-name)))
+ (clearcase-gui-diff-file-with-version buffer-file-name version))
+
+(defun clearcase-gui-diff-named-version-dired-file (version)
+ ;; nyi: if we're in history-mode, probably should just use
+ ;; (read-file-name)
+ ;;
+ (interactive (list (clearcase-read-version-name "Version for comparison: "
+ (dired-get-filename))))
+ (clearcase-gui-diff-file-with-version (clearcase-fprop-truename (dired-get-filename))
+ version))
+
+(defun clearcase-gui-diff-file-with-version (truename other-version)
+ (let* ((other-vxpath (clearcase-vxpath-cons-vxpath (clearcase-vxpath-element-part truename)
+ other-version))
+ (other-file (if (clearcase-file-is-in-mvfs-p truename)
+ other-vxpath
+ (clearcase-vxpath-get-version-in-temp-file other-vxpath)))
+ (gui-name (if clearcase-on-mswindows
+ "cleardiffmrg"
+ "xcleardiff")))
+ (start-process "Diff"
+ nil
+ gui-name
+ (clearcase-path-native other-file)
+ (clearcase-path-native truename))))
+
+;;}}}
+
+;;{{{ Diff
+
+(defun clearcase-diff-pred-current-buffer ()
+ "Use Diff to compare a version in the current buffer against its predecessor."
+ (interactive)
+ (clearcase-diff-file-with-version buffer-file-name
+ (clearcase-fprop-predecessor-version buffer-file-name)))
+
+(defun clearcase-diff-pred-dired-file ()
+ "Use Diff to compare the selected version against its predecessor."
+ (interactive)
+ (let ((truename (clearcase-fprop-truename (dired-get-filename))))
+ (clearcase-diff-file-with-version truename
+ (clearcase-fprop-predecessor-version truename))))
+
+(defun clearcase-diff-branch-base-current-buffer()
+ "Use Diff to compare a version in the current buffer
+against the base of its branch."
+ (interactive)
+ (clearcase-diff-file-with-version buffer-file-name
+ (clearcase-vxpath-version-of-branch-base buffer-file-name)))
+
+(defun clearcase-diff-branch-base-dired-file()
+ "Use Diff to compare the selected version against the base of its branch."
+ (interactive)
+ (let ((truename (clearcase-fprop-truename (dired-get-filename))))
+ (clearcase-diff-file-with-version truename
+ (clearcase-vxpath-version-of-branch-base truename))))
+
+(defun clearcase-diff-named-version-current-buffer (version)
+ ;; nyi: if we're in history-mode, probably should just use
+ ;; (read-file-name)
+ ;;
+ (interactive (list (clearcase-read-version-name "Version for comparison: "
+ buffer-file-name)))
+ (clearcase-diff-file-with-version buffer-file-name version))
+
+(defun clearcase-diff-named-version-dired-file (version)
+ ;; nyi: if we're in history-mode, probably should just use
+ ;; (read-file-name)
+ ;;
+ (interactive (list (clearcase-read-version-name "Version for comparison: "
+ (dired-get-filename))))
+ (clearcase-diff-file-with-version (clearcase-fprop-truename (dired-get-filename))
+ version))
+
+(defun clearcase-diff-file-with-version (truename other-version)
+ (let ((other-vxpath (clearcase-vxpath-cons-vxpath (clearcase-vxpath-element-part truename)
+ other-version)))
+ (if (clearcase-file-is-in-mvfs-p truename)
+ (clearcase-diff-files other-vxpath truename)
+ (clearcase-diff-files (clearcase-vxpath-get-version-in-temp-file other-vxpath)
+ truename))))
+
+;;}}}
+
+;;{{{ Browse vtree
+
+(defun clearcase-version-other-window (version)
+ (interactive
+ (list
+ (clearcase-read-version-name (format "Version of %s to visit: "
+ (file-name-nondirectory buffer-file-name))
+ buffer-file-name)))
+ (find-file-other-window (clearcase-vxpath-cons-vxpath
+ (clearcase-vxpath-element-part buffer-file-name)
+ version)))
+
+(defun clearcase-browse-vtree-current-buffer ()
+ (interactive)
+ (clearcase-browse-vtree buffer-file-name))
+
+(defun clearcase-browse-vtree-dired-file ()
+ (interactive)
+ (clearcase-browse-vtree (dired-get-filename)))
+
+;;}}}
+
+;;{{{ GUI vtree
+
+(defun clearcase-gui-vtree-browser-current-buffer ()
+ (interactive)
+ (clearcase-gui-vtree-browser buffer-file-name))
+
+(defun clearcase-gui-vtree-browser-dired-file ()
+ (interactive)
+ (clearcase-gui-vtree-browser (dired-get-filename)))
+
+(defun clearcase-gui-vtree-browser (file)
+ (let ((gui-name (if clearcase-on-mswindows
+ "clearvtree"
+ "xlsvtree")))
+ (start-process-shell-command "Vtree_browser"
+ nil
+ gui-name
+ (clearcase-path-native file))))
+
+;;}}}
+
+;;{{{ Other GUIs
+
+(defun clearcase-gui-clearexplorer ()
+ (interactive)
+ (start-process-shell-command "ClearExplorer"
+ nil
+ "clearexplorer"
+ "."))
+
+(defun clearcase-gui-rebase ()
+ (interactive)
+ (start-process-shell-command "Rebase"
+ nil
+ "clearmrgman"
+ (if clearcase-on-mswindows
+ "/rebase"
+ "-rebase")))
+
+(defun clearcase-gui-deliver ()
+ (interactive)
+ (start-process-shell-command "Deliver"
+ nil
+ "clearmrgman"
+ (if clearcase-on-mswindows
+ "/deliver"
+ "-deliver")))
+
+(defun clearcase-gui-merge-manager ()
+ (interactive)
+ (start-process-shell-command "Merge_manager"
+ nil
+ "clearmrgman"))
+
+(defun clearcase-gui-project-explorer ()
+ (interactive)
+ (start-process-shell-command "Project_explorer"
+ nil
+ "clearprojexp"))
+
+(defun clearcase-gui-snapshot-view-updater ()
+ (interactive)
+ (start-process-shell-command "View_updater"
+ nil
+ "clearviewupdate"))
+
+;;}}}
+
+;;{{{ Update snapshot
+
+;; In a file buffer:
+;; - update current-file
+;; - update directory
+;; In dired:
+;; - update dir
+;; - update marked files
+;; - update file
+
+;; We allow several simultaneous updates, but only one per view.
+
+(defun clearcase-update-view ()
+ (interactive)
+ (clearcase-update (clearcase-fprop-viewtag default-directory)))
+
+(defun clearcase-update-default-directory ()
+ (interactive)
+ (clearcase-update (clearcase-fprop-viewtag default-directory)
+ default-directory))
+
+(defun clearcase-update-current-buffer ()
+ (interactive)
+ (clearcase-update (clearcase-fprop-viewtag default-directory)
+ buffer-file-name))
+
+(defun clearcase-update-dired-files ()
+ (interactive)
+ (apply (function clearcase-update)
+ (cons (clearcase-fprop-viewtag default-directory)
+ (dired-get-marked-files))))
+
+
+;;}}}
+
+;;}}}
+
+;;{{{ Functions
+
+;;{{{ Basic ClearCase operations
+
+;;{{{ Update snapshot view
+
+;;{{{ Asynchronous post-processing of update
+
+(defvar clearcase-post-update-timer nil)
+(defvar clearcase-post-update-work-queue nil)
+
+(defun clearcase-post-update-schedule-work (buffer)
+ (clearcase-trace "entering clearcase-post-update-schedule-work")
+ ;; Add to the work queue.
+ ;;
+ (setq clearcase-post-update-work-queue (cons buffer
+ clearcase-post-update-work-queue))
+ ;; Create the timer if necessary.
+ ;;
+ (if (null clearcase-post-update-timer)
+ (if clearcase-xemacs-p
+ ;; Xemacs
+ ;;
+ (setq clearcase-post-update-timer
+ (run-with-idle-timer 2 t 'clearcase-post-update-timer-function))
+ ;; FSF Emacs
+ ;;
+ (progn
+ (setq clearcase-post-update-timer (timer-create))
+ (timer-set-function clearcase-post-update-timer 'clearcase-post-update-timer-function)
+ (timer-set-idle-time clearcase-post-update-timer 2)
+ (timer-activate-when-idle clearcase-post-update-timer)))
+ (clearcase-trace "clearcase-post-update-schedule-work: post-update timer found to be non-null")))
+
+
+(defun clearcase-post-update-timer-function ()
+ (clearcase-trace "Entering clearcase-post-update-timer-function")
+ ;; For (each update-process buffer in the work queue)
+ ;; if (its process has successfully terminated)
+ ;; do the post-processing for this update
+ ;; remove it from the work queue
+ ;;
+ (clearcase-trace (format "Queue before: %s" clearcase-post-update-work-queue))
+ (setq clearcase-post-update-work-queue
+
+ (clearcase-utl-list-filter
+ (function clearcase-post-update-check-process-buffer)
+ clearcase-post-update-work-queue))
+
+ (clearcase-trace (format "Queue after: %s" clearcase-post-update-work-queue))
+ ;; If the work queue is now empty cancel the timer.
+ ;;
+ (if (null clearcase-post-update-work-queue)
+ (progn
+ (cancel-timer clearcase-post-update-timer)
+ (setq clearcase-post-update-timer nil))))
+
+(defun clearcase-post-update-check-process-buffer (buffer)
+ (clearcase-trace "Entering clearcase-post-update-check-process-buffer")
+
+ ;; return t for those buffers that should remain in the work queue
+
+ ;; if it has terminated successfully
+ ;; go sync buffers on the files that were updated
+
+ ;; We want to field errors here and when they occurm return nil to avoid a
+ ;; loop
+ ;;
+ ;;(condition-case nil
+
+ ;; protected form
+ (let ((proc (get-buffer-process buffer)))
+ (if proc
+ ;; Process still exists so keep this on the work queue.
+ ;;
+ (progn
+ (clearcase-trace "Update process still exists")
+ t)
+
+ ;; Process no longer there, cleaned up by comint code.
+ ;;
+
+ ;; Sync any buffers that need it.
+ ;;
+ (clearcase-trace "Update process finished")
+ (clearcase-sync-after-scopes-updated (with-current-buffer buffer
+ ;; Evaluate buffer-local variable.
+ ;;
+ clearcase-update-buffer-scopes))
+
+ ;; Remove from work queue
+ ;;
+ nil))
+
+ ;; Error occurred, make sure we return nil to remove the buffer from the
+ ;; work queue, or a loop could develop.
+ ;;
+ ;;(error nil)
+ )
+
+(defun clearcase-sync-after-scopes-updated (scopes)
+ (clearcase-trace "Entering clearcase-sync-after-scopes-updated")
+
+ ;; nyi: reduce scopes to minimal set of disjoint scopes
+
+ ;; Use dynamic binding here since we don't have lexical binding.
+ ;;
+ (let ((clearcase-dynbound-updated-scopes scopes))
+
+ ;; For all buffers...
+ ;;
+ (mapcar
+ (function
+ (lambda (buffer)
+ (let ((visited-file (buffer-file-name buffer)))
+ (if visited-file
+ (if (clearcase-path-file-in-any-scopes visited-file
+ clearcase-dynbound-updated-scopes)
+ ;; This buffer visits a file within an updated scope.
+ ;; Sync it from disk if it needs it.
+ ;;
+ (clearcase-sync-from-disk-if-needed visited-file))
+
+ ;; Buffer is not visiting a file. If it is a dired-mode buffer
+ ;; under one of the scopes, revert it.
+ ;;
+ (with-current-buffer buffer
+ (if (eq 'dired-mode major-mode)
+ (if (clearcase-path-file-in-any-scopes default-directory
+ clearcase-dynbound-updated-scopes)
+ (dired-revert nil t))))))))
+ (buffer-list))))
+
+;;}}}
+
+;; Silence compiler complaints about free variable.
+;;
+(defvar clearcase-update-buffer-viewtag nil)
+
+(defun clearcase-update (viewtag &rest files)
+ "Run a cleartool+update process in VIEWTAG
+if there isn't one already running in that view.
+Other arguments FILES indicate files to update"
+
+ ;; Check that there is no update process running in that view.
+ ;;
+ (if (apply (function clearcase-utl-or-func)
+ (mapcar (function (lambda (proc)
+ (if (not (eq 'exit (process-status proc)))
+ (let ((buf (process-buffer proc)))
+ (and buf
+ (assq 'clearcase-update-buffer-viewtag
+ (buffer-local-variables buf))
+ (save-excursion
+ (set-buffer buf)
+ (equal viewtag
+ clearcase-update-buffer-viewtag)))))))
+ (process-list)))
+ (error "There is already an update running in view %s" viewtag))
+
+ ;; All clear so:
+ ;; - create a process in a buffer
+ ;; - rename the buffer to be of the form *clearcase-update*<N>
+ ;; - mark it as one of ours by setting clearcase-update-buffer-viewtag
+ ;;
+ (pop-to-buffer (apply (function make-comint)
+ (append (list "*clearcase-update-temp-name*"
+ clearcase-cleartool-path
+ nil
+ "update")
+ files))
+ t) ;; other window
+ (rename-buffer "*clearcase-update*" t)
+
+ ;; Store in this buffer what view was being updated and what files.
+ ;;
+ (set (make-local-variable 'clearcase-update-buffer-viewtag) viewtag)
+ (set (make-local-variable 'clearcase-update-buffer-scopes) files)
+
+ ;; nyi: schedule post-update buffer syncing
+ (clearcase-post-update-schedule-work (current-buffer)))
+
+;;}}}
+
+;;{{{ Hijack
+
+(defun clearcase-file-ok-to-hijack (file)
+
+ "Test if FILE is suitable for hijack."
+
+ (and
+
+ ;; If it is writeable already, no need to offer a hijack operation, even
+ ;; though, according to ClearCase, it may not yet be hijacked.
+ ;;
+ ;;(not (file-writable-p file))
+
+ (not (clearcase-fprop-hijacked file))
+ (clearcase-file-is-in-view-p file)
+ (not (clearcase-file-is-in-mvfs-p file))
+ (eq 'version (clearcase-fprop-mtype file))
+ (not (clearcase-fprop-checked-out file))))
+
+(defun clearcase-hijack-seq (files)
+ (unwind-protect
+ (progn
+ (message "Hijacking...")
+ (mapcar
+ (function
+ (lambda (file)
+ (if (not (file-directory-p file))
+ (clearcase-hijack file))))
+ files))
+ ;; Unwind
+ ;;
+ (message "Hijacking...done")))
+
+(defun clearcase-hijack (file)
+
+ ;; cases
+ ;; - buffer/files modtimes are equal
+ ;; - file more recent
+ ;; ==> revert
+ ;; - buffer more recent
+ ;; ==> make file writeable; save buffer ?
+ ;;
+ ;; Post-conditions:
+ ;; - file is hijacked wrt. CC
+ ;; - buffer is in sync with disk contents, modtime and writeability
+ ;; except if the user refused to save
+ ;;
+ (if (not (file-writable-p file))
+ ;; Make it writeable.
+ ;;
+ (clearcase-utl-make-writeable file))
+
+ ;; Attempt to modify the modtime of the file on disk, otherwise ClearCase
+ ;; won't actually deem it hijacked. This will silently fail if there is no
+ ;; "touch" command command available.
+ ;;
+ (clearcase-utl-touch-file file)
+
+ ;; Sync up any buffers.
+ ;;
+ (clearcase-sync-from-disk file t))
+
+;;}}}
+
+;;{{{ Unhijack
+
+(defun clearcase-file-ok-to-unhijack (file)
+ "Test if FILE is suitable for unhijack."
+ (clearcase-fprop-hijacked file))
+
+(defun clearcase-unhijack (file)
+ (clearcase-unhijack-seq (list file)))
+
+(defun cleartool-unhijack-parse-for-kept-files (ret snapshot-view-root)
+ ;; Look for occurrences of:
+ ;; Loading "source\emacs\.emacs.el" (296690 bytes).
+ ;; (renaming original hijacked object to ".emacs.el.keep.10").
+ ;;
+ (let ((start 0)
+ (kept-files nil))
+ (while (string-match
+ "^Loading \"\\([^\"]+\\)\"[^\n]+\n(renaming original hijacked object to \"\\([^\"]+\\)\")\\.\n"
+ ret
+ start)
+ (let* ((elt-path (substring ret (match-beginning 1) (match-end 1)))
+ (abs-elt-path (concat (if snapshot-view-root
+ snapshot-view-root
+ "/")
+ elt-path))
+ (abs-elt-dir (file-name-directory abs-elt-path ))
+ (kept-file-rel (concat abs-elt-dir
+ (substring ret (match-beginning 2) (match-end 2))))
+
+ ;; This is necessary on Windows to get an absolute path, i.e. one
+ ;; with a drive letter. Note: probably only correct if
+ ;; unhijacking files in a single snapshot view, mounted on a
+ ;; drive-letter.
+ ;;
+ (kept-file (expand-file-name kept-file-rel)))
+ (setq kept-files (cons kept-file kept-files)))
+ (setq start (match-end 0)))
+ kept-files))
+
+(defun clearcase-utl-files-in-same-view-p (files)
+ (if (< (length files) 2)
+ t
+ (let ((v0 (clearcase-fprop-viewtag (nth 0 files)))
+ (v1 (clearcase-fprop-viewtag (nth 1 files))))
+ (if (or (not (stringp v0))
+ (not (stringp v1))
+ (not (string= v0 v1)))
+ nil
+ (clearcase-utl-files-in-same-view-p (cdr files))))))
+
+(defun clearcase-unhijack-seq (files)
+
+ ;; Check: there are no directories involved.
+ ;;
+ (mapcar
+ (function
+ (lambda (file)
+ (if (file-directory-p file)
+ (error "Cannot unhijack a directory"))))
+ files)
+
+ ;; Check: all files are in the same snapshot view.
+ ;;
+ ;; (Why ? The output from ct+update only has view-root-relative paths
+ ;; and we need to obtain absolute paths of renamed-aside hijacks if we are to
+ ;; dired-relist them.)
+ ;;
+ ;; Alternative: partition the set, with each partition containing elements in
+ ;; the same view.
+ ;;
+ (if (not (clearcase-utl-files-in-same-view-p files))
+ (error "Can't unhijack files in different views in the same operation"))
+
+ ;; Run the scoped workspace update synchronously.
+ ;;
+ (unwind-protect
+ (progn
+ (message "Unhijacking...")
+ (let* ((ret (apply (function clearcase-ct-blocking-call)
+ (append (list "update"
+ (if clearcase-keep-unhijacks
+ "-rename"
+ "-overwrite")
+ "-log" clearcase-sink-file-name)
+ files)))
+ (snapshot-view-root (clearcase-file-snapshot-root (car files)))
+
+ ;; Scan for renamed-aside files.
+ ;;
+ (kept-files (if clearcase-keep-unhijacks
+ (cleartool-unhijack-parse-for-kept-files ret
+ snapshot-view-root)
+ nil)))
+
+ ;; Do post-update synchronisation.
+ ;;
+ (mapcar
+ (function clearcase-sync-after-file-updated-from-vob)
+ files)
+
+ ;; Update any dired buffers as to the existence of the kept files.
+ ;;
+ (if clearcase-keep-unhijacks
+ (mapcar (function
+ (lambda (file)
+ (dired-relist-file file)))
+ kept-files))))
+ ;; unwind
+ ;;
+ (message "Unhijacking...done")))
+
+;;}}}
+
+;;{{{ Mkelem
+
+(defun clearcase-file-ok-to-mkelem (file)
+ "Test if FILE is okay to mkelem."
+ (let ((mtype (clearcase-fprop-mtype file)))
+ (and (not (file-directory-p file))
+ (and (or (equal 'view-private-object mtype)
+ (equal 'derived-object mtype))
+ (not (clearcase-fprop-hijacked file))
+ (not (clearcase-file-covers-element-p file))))))
+
+(defun clearcase-assert-file-ok-to-mkelem (file)
+ "Raise an exception if FILE is not suitable for mkelem."
+ (if (not (clearcase-file-ok-to-mkelem file))
+ (error "%s cannot be made into an element" file)))
+
+(defun clearcase-commented-mkelem (file &optional okay-to-checkout-dir-first comment)
+ "Create a new element from FILE. If OKAY-TO-CHECKOUT-DIR-FIRST is non-nil,
+the containing directory will be checked out if necessary.
+If COMMENT is non-nil, it will be used, otherwise the user will be prompted
+to enter one."
+
+ ;; Pre-condition
+ ;;
+ (clearcase-assert-file-ok-to-mkelem file)
+
+ (let ((containing-dir (file-name-directory file)))
+
+ ;; Pre-condition
+ ;;
+ (if (not (eq 'directory-version (clearcase-fprop-mtype containing-dir)))
+ (error "Parent directory of %s is not a ClearCase versioned directory."
+ file))
+
+ ;; Determine if we'll need to checkout the parent directory first.
+ ;;
+ (let ((dir-checkout-needed (not (clearcase-fprop-checked-out containing-dir))))
+ (if dir-checkout-needed
+ (progn
+ ;; Parent dir will need to be checked out. Get permission if
+ ;; appropriate.
+ ;;
+ (if (null okay-to-checkout-dir-first)
+ (setq okay-to-checkout-dir-first
+ (or (null clearcase-verify-pre-mkelem-dir-checkout)
+ (y-or-n-p (format "Checkout directory %s " containing-dir)))))
+ (if (null okay-to-checkout-dir-first)
+ (error "Can't make an element unless directory is checked-out."))))
+
+ (if (null comment)
+ ;; If no comment supplied, go and get one...
+ ;;
+ (clearcase-comment-start-entry (file-name-nondirectory file)
+ "Enter initial comment for the new element."
+ 'clearcase-commented-mkelem
+ (list file okay-to-checkout-dir-first)
+ (find-file-noselect file)
+ clearcase-initial-mkelem-comment)
+
+ ;; ...otherwise perform the operation.
+ ;;
+
+ ;; We may need to checkout the directory.
+ ;;
+ (if dir-checkout-needed
+ (clearcase-commented-checkout containing-dir comment))
+
+ (clearcase-fprop-unstore-properties file)
+
+ (message "Making element %s..." file)
+
+ (save-excursion
+ ;; Sync the buffer to disk.
+ ;;
+ (let ((buffer-on-file (find-buffer-visiting file)))
+ (if buffer-on-file
+ (progn
+ (set-buffer buffer-on-file)
+ (clearcase-sync-to-disk))))
+
+ (clearcase-ct-do-cleartool-command "mkelem"
+ file
+ comment
+ (if clearcase-checkin-on-mkelem
+ (list "-ci")))
+ (message "Making element %s...done" file)
+
+ ;; Resync.
+ ;;
+ (clearcase-sync-from-disk file t))))))
+
+(defun clearcase-commented-mkelem-seq (files &optional comment)
+ "Mkelem a sequence of FILES. If COMMENT is supplied it will be
+used, otherwise the user will be prompted to enter one."
+
+ (mapcar
+ (function clearcase-assert-file-ok-to-mkelem)
+ files)
+
+ (if (null comment)
+ ;; No comment supplied, go and get one...
+ ;;
+ (clearcase-comment-start-entry "mkelem"
+ "Enter comment for elements' creation"
+ 'clearcase-commented-mkelem-seq
+ (list files))
+ ;; ...otherwise operate.
+ ;;
+ (mapcar
+ (function
+ (lambda (file)
+ (clearcase-commented-mkelem file nil comment)))
+ files)))
+
+;;}}}
+
+;;{{{ Checkin
+
+(defun clearcase-file-ok-to-checkin (file)
+ "Test if FILE is suitable for checkin."
+ (let ((me (user-login-name)))
+ (equal me (clearcase-fprop-owner-of-checkout file))))
+
+(defun clearcase-assert-file-ok-to-checkin (file)
+ "Raise an exception if FILE is not suitable for checkin."
+ (if (not (clearcase-file-ok-to-checkin file))
+ (error "You cannot checkin %s" file)))
+
+(defun clearcase-commented-checkin (file &optional comment)
+ "Check-in FILE with COMMENT. If the comment is omitted,
+a buffer is popped up to accept one."
+
+ (clearcase-assert-file-ok-to-checkin file)
+
+ (if (null comment)
+ ;; If no comment supplied, go and get one..
+ ;;
+ (progn
+ (clearcase-comment-start-entry (file-name-nondirectory file)
+ "Enter a checkin comment."
+ 'clearcase-commented-checkin
+ (list file)
+ (find-file-noselect file)
+ (clearcase-fprop-comment file))
+
+ ;; Also display a diff, if that is the custom:
+ ;;
+ (if (and (not (file-directory-p file))
+ clearcase-diff-on-checkin)
+ (save-excursion
+ (let ((tmp-buffer (current-buffer)))
+ (message "Running diff...")
+ (clearcase-diff-file-with-version file
+ (clearcase-fprop-predecessor-version file))
+ (message "Running diff...done")
+ (set-buffer "*clearcase*")
+ (if (get-buffer "*clearcase-diff*")
+ (kill-buffer "*clearcase-diff*"))
+ (rename-buffer "*clearcase-diff*")
+ (pop-to-buffer tmp-buffer)))))
+
+ ;; ...otherwise perform the operation.
+ ;;
+ (message "Checking in %s..." file)
+ (save-excursion
+ ;; Sync the buffer to disk, and get local value of clearcase-checkin-arguments
+ ;;
+ (let ((buffer-on-file (find-buffer-visiting file)))
+ (if buffer-on-file
+ (progn
+ (set-buffer buffer-on-file)
+ (clearcase-sync-to-disk))))
+ (clearcase-ct-do-cleartool-command "ci"
+ file
+ comment
+ clearcase-checkin-arguments))
+ (message "Checking in %s...done" file)
+
+ ;; Resync.
+ ;;
+ (clearcase-sync-from-disk file t)))
+
+(defun clearcase-commented-checkin-seq (files &optional comment)
+ "Checkin a sequence of FILES. If COMMENT is supplied it will be
+used, otherwise the user will be prompted to enter one."
+
+ ;; Check they're all in the right state to be checked-in.
+ ;;
+ (mapcar
+ (function clearcase-assert-file-ok-to-checkin)
+ files)
+
+ (if (null comment)
+ ;; No comment supplied, go and get one...
+ ;;
+ (clearcase-comment-start-entry "checkin"
+ "Enter checkin comment."
+ 'clearcase-commented-checkin-seq
+ (list files))
+ ;; ...otherwise operate.
+ ;;
+ (mapcar
+ (function
+ (lambda (file)
+ (clearcase-commented-checkin file comment)))
+ files)))
+
+;;}}}
+
+;;{{{ Checkout
+
+(defun clearcase-file-ok-to-checkout (file)
+ "Test if FILE is suitable for checkout."
+ (let ((mtype (clearcase-fprop-mtype file)))
+ (and (or (eq 'version mtype)
+ (eq 'directory-version mtype)
+ (clearcase-fprop-hijacked file))
+ (not (clearcase-fprop-checked-out file)))))
+
+(defun clearcase-assert-file-ok-to-checkout (file)
+ "Raise an exception if FILE is not suitable for checkout."
+ (if (not (clearcase-file-ok-to-checkout file))
+ (error "You cannot checkout %s" file)))
+
+;; nyi: Offer to setact if appropriate
+
+(defun clearcase-commented-checkout (file &optional comment)
+ "Check-out FILE with COMMENT. If the comment is omitted,
+a buffer is popped up to accept one."
+
+ (clearcase-assert-file-ok-to-checkout file)
+
+ (if (and (null comment)
+ (not clearcase-suppress-checkout-comments))
+ ;; If no comment supplied, go and get one...
+ ;;
+ (clearcase-comment-start-entry (file-name-nondirectory file)
+ "Enter a checkout comment."
+ 'clearcase-commented-checkout
+ (list file)
+ (find-file-noselect file))
+
+ ;; ...otherwise perform the operation.
+ ;;
+ (message "Checking out %s..." file)
+ ;; Change buffers to get local value of clearcase-checkin-arguments.
+ ;;
+ (save-excursion
+ (set-buffer (or (find-buffer-visiting file)
+ (current-buffer)))
+ (clearcase-ct-do-cleartool-command "co"
+ file
+ comment
+ clearcase-checkout-arguments))
+ (message "Checking out %s...done" file)
+
+ ;; Resync.
+ ;;
+ (clearcase-sync-from-disk file t)))
+
+
+(defun clearcase-commented-checkout-seq (files &optional comment)
+ "Checkout a sequence of FILES. If COMMENT is supplied it will be
+used, otherwise the user will be prompted to enter one."
+
+ (mapcar
+ (function clearcase-assert-file-ok-to-checkout)
+ files)
+
+ (if (and (null comment)
+ (not clearcase-suppress-checkout-comments))
+ ;; No comment supplied, go and get one...
+ ;;
+ (clearcase-comment-start-entry "checkout"
+ "Enter a checkout comment."
+ 'clearcase-commented-checkout-seq
+ (list files))
+ ;; ...otherwise operate.
+ ;;
+ (mapcar
+ (function
+ (lambda (file)
+ (clearcase-commented-checkout file comment)))
+ files)))
+
+;;}}}
+
+;;{{{ Uncheckout
+
+(defun clearcase-file-ok-to-uncheckout (file)
+ "Test if FILE is suitable for uncheckout."
+ (equal (user-login-name)
+ (clearcase-fprop-owner-of-checkout file)))
+
+(defun clearcase-assert-file-ok-to-uncheckout (file)
+ "Raise an exception if FILE is not suitable for uncheckout."
+ (if (not (clearcase-file-ok-to-uncheckout file))
+ (error "You cannot uncheckout %s" file)))
+
+(defun cleartool-unco-parse-for-kept-file (ret)
+ ;;Private version of "foo" saved in "foo.keep.1"
+ (if (string-match "^Private version of .* saved in \"\\([^\"]+\\)\"\\.$" ret)
+ (substring ret (match-beginning 1) (match-end 1))
+ nil))
+
+(defun clearcase-uncheckout (file)
+ "Uncheckout FILE."
+
+ (clearcase-assert-file-ok-to-uncheckout file)
+
+ ;; If it has changed since checkout, insist the user confirm.
+ ;;
+ (if (and (not (file-directory-p file))
+ (clearcase-file-appears-modified-since-checkout-p file)
+ (not clearcase-suppress-confirm)
+ (not (yes-or-no-p (format "Really discard changes to %s ?" file))))
+ (message "Uncheckout of %s cancelled" file)
+
+ ;; Go ahead and unco.
+ ;;
+ (message "Cancelling checkout of %s..." file)
+ ;; nyi:
+ ;; - Prompt for -keep or -rm
+ ;; - offer to remove /0 branches
+ ;;
+ (let* ((ret (clearcase-ct-blocking-call "unco"
+ (if clearcase-keep-uncheckouts
+ "-keep"
+ "-rm")
+ file))
+ ;; Discover the name of the saved.
+ ;;
+ (kept-file (if clearcase-keep-uncheckouts
+ (cleartool-unco-parse-for-kept-file ret)
+ nil)))
+
+ (if kept-file
+ (message "Checkout of %s cancelled (saved in %s)"
+ (file-name-nondirectory kept-file)
+ file)
+ (message "Cancelling checkout of %s...done" file))
+
+ ;; Sync any buffers over the file itself.
+ ;;
+ (clearcase-sync-from-disk file t)
+
+ ;; Update any dired buffers as to the existence of the kept file.
+ ;;
+ (if kept-file
+ (dired-relist-file kept-file)))))
+
+(defun clearcase-uncheckout-seq (files)
+ "Uncheckout a sequence of FILES."
+
+ (mapcar
+ (function clearcase-assert-file-ok-to-uncheckout)
+ files)
+
+ (mapcar
+ (function clearcase-uncheckout)
+ files))
+
+;;}}}
+
+;;{{{ Describe
+
+(defun clearcase-describe (file)
+ "Give a ClearCase description of FILE."
+
+ (clearcase-utl-populate-and-view-buffer
+ "*clearcase*"
+ (list file)
+ (function
+ (lambda (file)
+ (clearcase-ct-do-cleartool-command "describe" file 'unused)))))
+
+(defun clearcase-describe-seq (files)
+ "Give a ClearCase description of the sequence of FILES."
+ (error "Not yet implemented"))
+
+;;}}}
+
+;;{{{ Mkbrtype
+
+(defun clearcase-commented-mkbrtype (typename &optional comment)
+ (if (null comment)
+ (clearcase-comment-start-entry (format "mkbrtype:%s" typename)
+ "Enter a comment for the new branch type."
+ 'clearcase-commented-mkbrtype
+ (list typename))
+ (clearcase-with-tempfile
+ comment-file
+ (write-region comment nil comment-file nil 'noprint)
+ (let ((qualified-typename typename))
+ (if (not (string-match "@" typename))
+ (setq qualified-typename
+ (format "%s@%s" typename default-directory)))
+
+ (clearcase-ct-cleartool-cmd "mkbrtype"
+ "-cfile"
+ (clearcase-path-native comment-file)
+ qualified-typename)))))
+
+;;}}}
+
+;;{{{ Browse vtree (using Dired Mode)
+
+(defun clearcase-file-ok-to-browse (file)
+ (and file
+ (or (equal 'version (clearcase-fprop-mtype file))
+ (equal 'directory-version (clearcase-fprop-mtype file)))
+ (clearcase-file-is-in-mvfs-p file)))
+
+(defun clearcase-browse-vtree (file)
+ (if (not (clearcase-fprop-file-is-version-p file))
+ (error "%s is not a Clearcase element" file))
+
+ (if (not (clearcase-file-is-in-mvfs-p file))
+ (error "File is not in MVFS"))
+
+ (let* ((version-path (clearcase-vxpath-cons-vxpath
+ file
+ (or (clearcase-vxpath-version-part file)
+ (clearcase-fprop-version file))))
+ ;; nyi: Can't seem to get latest first here.
+ ;;
+ (dired-listing-switches (concat dired-listing-switches
+ "rt"))
+
+ (branch-path (clearcase-vxpath-branch version-path))
+
+ ;; Position cursor to the version we came from.
+ ;; If it was checked-out, go to predecessor.
+ ;;
+ (version-number (clearcase-vxpath-version
+ (if (clearcase-fprop-checked-out file)
+ (clearcase-fprop-predecessor-version file)
+ version-path))))
+
+ (if (file-exists-p version-path)
+ (progn
+ ;; Invoke dired on the directory of the version branch.
+ ;;
+ (dired branch-path)
+
+ (clearcase-dired-sort-by-date)
+
+ (if (re-search-forward (concat "[ \t]+"
+ "\\("
+ (regexp-quote version-number)
+ "\\)"
+ "$")
+ nil
+ t)
+ (goto-char (match-beginning 1))))
+ (dired (concat file clearcase-vxpath-glue))
+
+ ;; nyi: We want ANY directory in the history tree to appear with
+ ;; newest first. Probably requires a hook to dired mode.
+ ;;
+ (clearcase-dired-sort-by-date))))
+
+;;}}}
+
+;;{{{ List history
+
+(defun clearcase-list-history (file)
+ "List the change history of FILE.
+
+FILE can be a file or a directory. If it is a directory, only the information
+on the directory element itself is listed, not on its contents."
+
+ (let ((mtype (clearcase-fprop-mtype file)))
+ (if (or (eq mtype 'version)
+ (eq mtype 'directory-version))
+ (progn
+ (message "Listing element history...")
+
+ (clearcase-utl-populate-and-view-buffer
+ "*clearcase*"
+ (list file)
+ (function
+ (lambda (file)
+ (clearcase-ct-do-cleartool-command "lshistory"
+ file
+ 'unused
+ (if (eq mtype 'directory-version)
+ (list "-d")))
+ (setq default-directory (file-name-directory file))
+ (while (looking-at "=3D*\n")
+ (delete-char (- (match-end 0) (match-beginning 0)))
+ (forward-line -1))
+ (goto-char (point-min))
+ (if (looking-at "[\b\t\n\v\f\r ]+")
+ (delete-char (- (match-end 0) (match-beginning 0)))))))
+ (message "Listing element history...done"))
+
+ (error "%s is not a ClearCase element" file))))
+
+;;}}}
+
+;;{{{ Diff/cmp
+
+(defun clearcase-files-are-identical (f1 f2)
+ "Test if FILE1 and FILE2 have identical contents."
+
+ (clearcase-when-debugging
+ (if (not (file-exists-p f1))
+ (error "%s non-existent" f1))
+ (if (not (file-exists-p f2))
+ (error "%s non-existent" f2)))
+
+ (zerop (call-process "cleardiff" nil nil nil "-status_only" f1 f2)))
+
+(defun clearcase-diff-files (file1 file2)
+ "Run cleardiff on FILE1 and FILE2 and display the differences."
+ (if clearcase-use-normal-diff
+ (clearcase-do-command 2
+ clearcase-normal-diff-program
+ file2
+ (append clearcase-normal-diff-arguments
+ (list file1)))
+ (clearcase-do-command 2
+ "cleardiff"
+ file2
+ (list "-diff_format" file1)))
+ (let ((diff-size (save-excursion
+ (set-buffer "*clearcase*")
+ (buffer-size))))
+ (if (zerop diff-size)
+ (message "No differences")
+ (clearcase-port-view-buffer-other-window "*clearcase*")
+ (goto-char 0)
+ (shrink-window-if-larger-than-buffer))))
+
+;;}}}
+
+;;{{{ What rule
+
+(defun clearcase-what-rule (file)
+ (let ((result (clearcase-ct-cleartool-cmd "ls"
+ "-d"
+ (clearcase-path-native file))))
+ (if (string-match "Rule: \\(.*\\)\n" result)
+ (message (substring result
+ ;; Be a little more verbose
+ (match-beginning 0) (match-end 1)))
+ (error result))))
+
+;;}}}
+
+;;}}}
+
+;;{{{ File property cache
+
+;; ClearCase properties of files are stored in a vector in a hashtable with the
+;; absolute-filename (with no trailing slashes) as the lookup key.
+;;
+;; Properties are:
+;;
+;; [0] truename : string
+;; [1] mtype : { nil, view-private-object, version,
+;; directory-version, file-element,
+;; dir-element, derived-object
+;; }
+;; [2] checked-out : boolean
+;; [3] reserved : boolean
+;; [4] version : string
+;; [5] predecessor-version : string
+;; [6] oid : string
+;; [7] user : string
+;; [8] date : string (yyyymmdd.hhmmss)
+;; [9] time-last-described : (N, N, N) time when the properties were last read
+;; from ClearCase
+;; [10] viewtag : string
+;; [11] comment : string
+;; [12] slink-text : string (empty string if not symlink)
+;; [13] hijacked : boolean
+
+;; nyi: other possible properties to record:
+;; mtime when last described (lets us know when the cached properties
+;; might be stale)
+
+;;{{{ Debug code
+
+(defun clearcase-fprop-unparse-properties (properties)
+ "Return a string suitable for printing PROPERTIES."
+ (concat
+ (format "truename: %s\n" (aref properties 0))
+ (format "mtype: %s\n" (aref properties 1))
+ (format "checked-out: %s\n" (aref properties 2))
+ (format "reserved: %s\n" (aref properties 3))
+ (format "version: %s\n" (aref properties 4))
+ (format "predecessor-version: %s\n" (aref properties 5))
+ (format "oid: %s\n" (aref properties 6))
+ (format "user: %s\n" (aref properties 7))
+ (format "date: %s\n" (aref properties 8))
+ (format "time-last-described: %s\n" (current-time-string (aref properties 9)))
+ (format "viewtag: %s\n" (aref properties 10))
+ (format "comment: %s\n" (aref properties 11))
+ (format "slink-text: %s\n" (aref properties 12))
+ (format "hijacked: %s\n" (aref properties 13))))
+
+(defun clearcase-fprop-display-properties (file)
+ "Display the recorded ClearCase properties of FILE."
+ (interactive "F")
+ (let* ((abs-file (expand-file-name file))
+ (properties (clearcase-fprop-lookup-properties abs-file)))
+ (if properties
+ (let ((unparsed-properties (clearcase-fprop-unparse-properties properties)))
+ (clearcase-utl-populate-and-view-buffer
+ "*clearcase*"
+ nil
+ (function (lambda ()
+ (insert unparsed-properties)))))
+ (error "Properties for %s not stored" file))))
+
+(defun clearcase-fprop-dump-to-current-buffer ()
+ "Dump to the current buffer the table recording ClearCase properties of files."
+ (interactive)
+ (insert (format "File describe count: %s\n" clearcase-fprop-describe-count))
+ (mapatoms
+ (function
+ (lambda (symbol)
+ (let ((properties (symbol-value symbol)))
+ (insert "\n"
+ (format "key: %s\n" (symbol-name symbol))
+ "\n"
+ (clearcase-fprop-unparse-properties properties)))))
+ clearcase-fprop-hashtable)
+ (insert "\n"))
+
+(defun clearcase-fprop-dump ()
+ (interactive)
+ (clearcase-utl-populate-and-view-buffer
+ "*clearcase*"
+ nil
+ (function (lambda ()
+ (clearcase-fprop-dump-to-current-buffer)))))
+
+;;}}}
+
+(defvar clearcase-fprop-hashtable (make-vector 31 0)
+ "Obarray for per-file ClearCase properties.")
+
+(defun clearcase-fprop-canonicalise-path (filename)
+ ;; We want DIR/y and DIR\y to map to the same cache entry on ms-windows.
+ ;; We want DIR and DIR/ (and on windows DIR\) to map to the same cache entry.
+ ;;
+ ;; However, on ms-windows avoid canonicalising X:/ to X: because, for some
+ ;; reason, cleartool+desc fails on X:, but works on X:/
+ ;;
+ (setq filename (clearcase-path-canonicalise-slashes filename))
+ (if (and clearcase-on-mswindows
+ (string-match (concat "^" "[A-Za-z]:" clearcase-pname-sep-regexp "$")
+ filename))
+ filename
+ (clearcase-utl-strip-trailing-slashes filename)))
+
+(defun clearcase-fprop-clear-all-properties ()
+ "Delete all entries in the clearcase-fprop-hashtable."
+ (setq clearcase-fprop-hashtable (make-vector 31 0)))
+
+(defun clearcase-fprop-store-properties (file properties)
+ "For FILE, store its ClearCase PROPERTIES in the clearcase-fprop-hashtable."
+ (assert (file-name-absolute-p file))
+ (set (intern (clearcase-fprop-canonicalise-path file)
+ clearcase-fprop-hashtable) properties))
+
+(defun clearcase-fprop-unstore-properties (file)
+ "For FILE, delete its entry in the clearcase-fprop-hashtable."
+ (assert (file-name-absolute-p file))
+ (unintern (clearcase-fprop-canonicalise-path file) clearcase-fprop-hashtable))
+
+(defun clearcase-fprop-lookup-properties (file)
+ "For FILE, lookup and return its ClearCase properties from the
+clearcase-fprop-hashtable."
+ (assert (file-name-absolute-p file))
+ (symbol-value (intern-soft (clearcase-fprop-canonicalise-path file)
+ clearcase-fprop-hashtable)))
+
+(defun clearcase-fprop-get-properties (file)
+ "For FILE, make sure its ClearCase properties are in the hashtable
+and then return them."
+ (or (clearcase-fprop-lookup-properties file)
+ (let ((properties
+ (condition-case signal-info
+ (clearcase-fprop-read-properties file)
+ (error
+ (progn
+ (clearcase-trace (format "(clearcase-fprop-read-properties %s) signalled error: %s"
+ file
+ (cdr signal-info)))
+ (make-vector 31 nil))))))
+ (clearcase-fprop-store-properties file properties)
+ properties)))
+
+(defun clearcase-fprop-truename (file)
+ "For FILE, return its \"truename\" ClearCase property."
+ (aref (clearcase-fprop-get-properties file) 0))
+
+(defun clearcase-fprop-mtype (file)
+ "For FILE, return its \"mtype\" ClearCase property."
+ (aref (clearcase-fprop-get-properties file) 1))
+
+(defun clearcase-fprop-checked-out (file)
+ "For FILE, return its \"checked-out\" ClearCase property."
+ (aref (clearcase-fprop-get-properties file) 2))
+
+(defun clearcase-fprop-reserved (file)
+ "For FILE, return its \"reserved\" ClearCase property."
+ (aref (clearcase-fprop-get-properties file) 3))
+
+(defun clearcase-fprop-version (file)
+ "For FILE, return its \"version\" ClearCase property."
+ (aref (clearcase-fprop-get-properties file) 4))
+
+(defun clearcase-fprop-predecessor-version (file)
+ "For FILE, return its \"predecessor-version\" ClearCase property."
+ (aref (clearcase-fprop-get-properties file) 5))
+
+(defun clearcase-fprop-oid (file)
+ "For FILE, return its \"oid\" ClearCase property."
+ (aref (clearcase-fprop-get-properties file) 6))
+
+(defun clearcase-fprop-user (file)
+ "For FILE, return its \"user\" ClearCase property."
+ (aref (clearcase-fprop-get-properties file) 7))
+
+(defun clearcase-fprop-date (file)
+ "For FILE, return its \"date\" ClearCase property."
+ (aref (clearcase-fprop-get-properties file) 8))
+
+(defun clearcase-fprop-time-last-described (file)
+ "For FILE, return its \"time-last-described\" ClearCase property."
+ (aref (clearcase-fprop-get-properties file) 9))
+
+(defun clearcase-fprop-viewtag (file)
+ "For FILE, return its \"viewtag\" ClearCase property."
+ (aref (clearcase-fprop-get-properties file) 10))
+
+(defun clearcase-fprop-comment (file)
+ "For FILE, return its \"comment\" ClearCase property."
+ (aref (clearcase-fprop-get-properties file) 11))
+
+(defun clearcase-fprop-vob-slink-text (file)
+ "For FILE, return its \"slink-text\" ClearCase property."
+ (aref (clearcase-fprop-get-properties file) 12))
+
+(defun clearcase-fprop-hijacked (file)
+ "For FILE, return its \"hijacked\" ClearCase property."
+ (aref (clearcase-fprop-get-properties file) 13))
+
+(defun clearcase-fprop-set-comment (file comment)
+ "For FILE, set its \"comment\" ClearCase property to COMMENT."
+ (aset (clearcase-fprop-get-properties file) 11 comment))
+
+(defun clearcase-fprop-owner-of-checkout (file)
+ "For FILE, return whether the current user has it checked-out."
+ (if (clearcase-fprop-checked-out file)
+ (clearcase-fprop-user file)
+ nil))
+
+(defun clearcase-fprop-file-is-vob-slink-p (object-name)
+ (not (zerop (length (clearcase-fprop-vob-slink-text object-name)))))
+
+(defun clearcase-fprop-file-is-version-p (object-name)
+ (if object-name
+ (let ((mtype (clearcase-fprop-mtype object-name)))
+ (or (eq 'version mtype)
+ (eq 'directory-version mtype)))))
+
+;; Read the object's ClearCase properties using cleartool and the Lisp reader.
+;;
+;; nyi: for some reason the \n before the %c necessary here so avoid confusing the
+;; cleartool/tq interface. Completely mysterious. Arrived at by
+;; trial and error.
+;;
+(defvar clearcase-fprop-fmt-string
+
+ ;; Yuck. Different forms of quotation are needed here apparently to deal with
+ ;; all the various ways of spawning sub-process on the the various platforms
+ ;; (XEmacs vs. GnuEmacs, Win32 vs. Unix, Cygwin-built vs. native-built).
+ ;;
+ (if clearcase-on-mswindows
+ (if clearcase-xemacs-p
+ ;; XEmacs/Windows
+ ;;
+ (if clearcase-on-cygwin
+ ;; Cygwin build
+ ;;
+ "[nil \\\"%m\\\" \\\"%f\\\" \\\"%Rf\\\" \\\"%Sn\\\" \\\"%PSn\\\" \\\"%On\\\" \\\"%u\\\" \\\"%Nd\\\" nil nil nil \\\"%[slink_text]p\\\" nil ]\\n%c"
+ ;; Native build
+ ;;
+ "[nil \\\"%m\\\" \\\"%f\\\" \\\"%Rf\\\" \\\"%Sn\\\" \\\"%PSn\\\" \\\"%On\\\" \\\"%u\\\" \\\"%Nd\\\" nil nil nil \\\"%[slink_text]p\\\" nil]\n%c")
+
+ ;; GnuEmacs/Windows
+ ;;
+ "[nil \"%m\" \"%f\" \"%Rf\" \"%Sn\" \"%PSn\" \"%On\" \"%u\" \"%Nd\" nil nil nil \"%[slink_text]p\" nil]\\n%c")
+
+ ;; Unix
+ ;;
+ "'[nil \"%m\" \"%f\" \"%Rf\" \"%Sn\" \"%PSn\" \"%On\" \"%u\" \"%Nd\" nil nil nil \"%[slink_text]p\" nil]\\n%c'")
+
+ "Format for cleartool+describe command when reading the
+ClearCase properties of a file")
+
+(defvar clearcase-fprop-describe-count 0
+ "Count the number of times clearcase-fprop-read-properties is called")
+
+(defun clearcase-fprop-read-properties (file)
+ "Invoke the cleartool+describe command to obtain the ClearCase
+properties of FILE."
+ (assert (file-name-absolute-p file))
+ (let* ((truename (clearcase-fprop-canonicalise-path (file-truename (expand-file-name file)))))
+
+ ;; If the object doesn't exist, signal an error
+ ;;
+ (if (or (not (file-exists-p (clearcase-vxpath-element-part file)))
+ (not (file-exists-p (clearcase-vxpath-element-part truename))))
+ (error "File doesn't exist: %s" file)
+
+ ;; Run cleartool+ describe and capture the output as a string:
+ ;;
+ (let ((desc-string (clearcase-ct-cleartool-cmd "desc"
+ "-fmt"
+ clearcase-fprop-fmt-string
+ (clearcase-path-native truename))))
+ (setq clearcase-fprop-describe-count (1+ clearcase-fprop-describe-count))
+
+ ;;(clearcase-trace (format "desc of %s <<<<" truename))
+ ;;(clearcase-trace desc-string)
+ ;;(clearcase-trace (format "desc of %s >>>>" truename))
+
+ ;; Read all but the comment, using the Lisp reader, and then copy
+ ;; what's left as the comment. We don't try to use the Lisp reader to
+ ;; fetch the comment to avoid problems with quotation.
+ ;;
+ ;; nyi: it would be nice if we could make cleartool use "/" as pname-sep,
+ ;; because read-from-string will barf on imbedded "\". For now
+ ;; run clearcase-path-canonicalise-slashes over the cleartool
+ ;; output before invoking the Lisp reader.
+ ;;
+ (let* ((first-read (read-from-string (clearcase-path-canonicalise-slashes desc-string)))
+ (result (car first-read))
+ (bytes-read (cdr first-read))
+ (comment (substring desc-string (1+ bytes-read)))) ;; skip \n
+
+ ;; Plug in the slots I left empty:
+ ;;
+ (aset result 0 truename)
+ (aset result 9 (current-time))
+
+ (aset result 11 comment)
+
+ ;; Convert mtype to an enumeration:
+ ;;
+ (let ((mtype-string (aref result 1)))
+ (cond
+ ((string= mtype-string "version")
+ (aset result 1 'version))
+
+ ((string= mtype-string "directory version")
+ (aset result 1 'directory-version))
+
+ ((string= mtype-string "view private object")
+ (aset result 1 'view-private-object)
+
+ ;; If we're in a snapshot see if it is hijacked by running
+ ;; ct+desc FILE@@. No error indicates it's hijacked.
+ ;;
+ (if (clearcase-file-would-be-in-snapshot-p truename)
+ (aset result 13
+ (condition-case nil
+ (stringp
+ (clearcase-ct-cleartool-cmd
+ "desc"
+ "-short"
+ (concat (clearcase-path-native truename)
+ clearcase-vxpath-glue)))
+ (error nil)))))
+
+ ((string= mtype-string "file element")
+ (aset result 1 'file-element))
+
+ ((string= mtype-string "directory element")
+ (aset result 1 'directory-element))
+
+ ((string= mtype-string "derived object")
+ (aset result 1 'derived-object))
+
+ ;; For now treat checked-in DOs as versions.
+ ;;
+ ((string= mtype-string "derived object version")
+ (aset result 1 'version))
+
+ ;; On NT, coerce the mtype of symlinks into that
+ ;; of their targets.
+ ;;
+ ;; nyi: I think this is approximately right.
+ ;;
+ ((and (string= mtype-string "symbolic link")
+ clearcase-on-mswindows)
+ (if (file-directory-p truename)
+ (aset result 1 'directory-version)
+ (aset result 1 'version)))
+
+ ;; We get this on paths like foo.c@@/main
+ ;;
+ ((string= mtype-string "branch")
+ (aset result 1 'branch))
+
+ ((string= mtype-string "**null meta type**")
+ (aset result 1 nil))
+
+ (t
+ (error "Unknown mtype returned by cleartool+describe: %s"
+ mtype-string))))
+
+ ;; nyi: possible efficiency win: only evaluate the viewtag on demand.
+ ;;
+ (if (aref result 1)
+ (aset result 10 (clearcase-file-viewtag truename)))
+
+ ;; Convert checked-out field to boolean:
+ ;;
+ (aset result 2 (not (zerop (length (aref result 2)))))
+
+ ;; Convert reserved field to boolean:
+ ;;
+ (aset result 3 (string= "reserved" (aref result 3)))
+
+ ;; Return the array of properties.
+ ;;
+ result)))))
+
+;;}}}
+
+;;{{{ View property cache
+
+;; ClearCase properties of views are stored in a vector in a hashtable
+;; with the viewtag as the lookup key.
+;;
+;; Properties are:
+;;
+;; [0] ucm : boolean
+;; [1] stream : string
+;; [2] pvob : string
+;; [3] activities : list of strings
+;; [4] current-activity : string
+
+;;{{{ Debug code
+
+(defun clearcase-vprop-dump-to-current-buffer ()
+ "Dump to the current buffer the table recording ClearCase properties of views."
+ (insert (format "View describe count: %s\n" clearcase-vprop-describe-count))
+ (mapatoms
+ (function
+ (lambda (symbol)
+ (let ((properties (symbol-value symbol)))
+ (insert "\n"
+ (format "viewtag: %s\n" (symbol-name symbol))
+ "\n"
+ (clearcase-vprop-unparse-properties properties)))))
+ clearcase-vprop-hashtable)
+ (insert "\n"))
+
+(defun clearcase-vprop-dump ()
+ (interactive)
+ (clearcase-utl-populate-and-view-buffer
+ "*clearcase*"
+ nil
+ (function (lambda ()
+ (clearcase-vprop-dump-to-current-buffer)))))
+
+(defun clearcase-vprop-unparse-properties (properties)
+ "Return a string suitable for printing PROPERTIES."
+ (concat
+ (format "ucm: %s\n" (aref properties 0))
+ (format "stream: %s\n" (aref properties 1))
+ (format "pvob: %s\n" (aref properties 2))
+ (format "activities: %s\n" (aref properties 3))
+ (format "current-activity: %s\n" (aref properties 4))))
+
+;;}}}
+
+;;{{{ Asynchronously fetching view properties:
+
+(defvar clearcase-vprop-timer nil)
+(defvar clearcase-vprop-work-queue nil)
+
+(defun clearcase-vprop-schedule-work (viewtag)
+ ;; Add to the work queue.
+ ;;
+ (setq clearcase-vprop-work-queue (cons viewtag
+ clearcase-vprop-work-queue))
+ ;; Create the timer if necessary.
+ ;;
+ (if (null clearcase-vprop-timer)
+ (if clearcase-xemacs-p
+ ;; Xemacs
+ ;;
+ (setq clearcase-vprop-timer
+ (run-with-idle-timer 5 t 'clearcase-vprop-timer-function))
+ ;; FSF Emacs
+ ;;
+ (progn
+ (setq clearcase-vprop-timer (timer-create))
+ (timer-set-function clearcase-vprop-timer 'clearcase-vprop-timer-function)
+ (timer-set-idle-time clearcase-vprop-timer 5)
+ (timer-activate-when-idle clearcase-vprop-timer)))))
+
+(defun clearcase-vprop-timer-function ()
+ ;; Process the work queue and empty it.
+ ;;
+ (mapcar (function (lambda (viewtag)
+ (clearcase-vprop-get-properties viewtag)))
+ clearcase-vprop-work-queue)
+ (setq clearcase-vprop-work-queue nil)
+
+ ;; Cancel the timer.
+ ;;
+ (cancel-timer clearcase-vprop-timer)
+ (setq clearcase-vprop-timer nil))
+
+;;}}}
+
+(defvar clearcase-vprop-hashtable (make-vector 31 0)
+ "Obarray for per-view ClearCase properties.")
+
+(defun clearcase-vprop-clear-all-properties ()
+ "Delete all entries in the clearcase-vprop-hashtable."
+ (setq clearcase-vprop-hashtable (make-vector 31 0)))
+
+(defun clearcase-vprop-store-properties (viewtag properties)
+ "For VIEW, store its ClearCase PROPERTIES in the clearcase-vprop-hashtable."
+ (set (intern viewtag clearcase-vprop-hashtable) properties))
+
+(defun clearcase-vprop-unstore-properties (viewtag)
+ "For VIEWTAG, delete its entry in the clearcase-vprop-hashtable."
+ (unintern viewtag clearcase-vprop-hashtable))
+
+(defun clearcase-vprop-lookup-properties (viewtag)
+ "For VIEWTAG, lookup and return its ClearCase properties from the
+clearcase-vprop-hashtable."
+ (symbol-value (intern-soft viewtag clearcase-vprop-hashtable)))
+
+(defun clearcase-vprop-get-properties (viewtag)
+ "For VIEWTAG, make sure it's ClearCase properties are in the hashtable
+and then return them."
+ (or (clearcase-vprop-lookup-properties viewtag)
+ (let ((properties (clearcase-vprop-read-properties viewtag)))
+ (clearcase-vprop-store-properties viewtag properties)
+ properties)))
+
+(defun clearcase-vprop-ucm (viewtag)
+ "For VIEWTAG, return its \"ucm\" ClearCase property."
+ (aref (clearcase-vprop-get-properties viewtag) 0))
+
+(defun clearcase-vprop-stream (viewtag)
+ "For VIEWTAG, return its \"stream\" ClearCase property."
+ (aref (clearcase-vprop-get-properties viewtag) 1))
+
+(defun clearcase-vprop-pvob (viewtag)
+ "For VIEWTAG, return its \"stream\" ClearCase property."
+ (aref (clearcase-vprop-get-properties viewtag) 2))
+
+(defun clearcase-vprop-activities (viewtag)
+ "For VIEWTAG, return its \"activities\" ClearCase property."
+
+ ;; If the activity set has been flushed, go and schedule a re-fetch.
+ ;;
+ (let ((properties (clearcase-vprop-get-properties viewtag)))
+ (if (null (aref properties 3))
+ (aset properties 3 (clearcase-vprop-read-activities-asynchronously viewtag))))
+
+ ;; Now poll, waiting for the activities to be available.
+ ;;
+ (let ((loop-count 0))
+ ;; If there is a background process still reading the activities,
+ ;; wait for it to finish.
+ ;;
+ ;; nyi: probably want a timeout here.
+ ;;
+ ;; nyi: There seems to be a race on NT in accept-process-output so that
+ ;; we would wait forever.
+ ;;
+ (if (not clearcase-on-mswindows)
+ ;; Unix synchronization with the end of the process
+ ;; which is reading activities.
+ ;;
+ (while (bufferp (aref (clearcase-vprop-get-properties viewtag) 3))
+ (save-excursion
+ (set-buffer (aref (clearcase-vprop-get-properties viewtag) 3))
+ (message "Reading activity list...")
+ (setq loop-count (1+ loop-count))
+ (accept-process-output clearcase-vprop-async-proc)))
+
+ ;; NT synchronization with the end of the process which is reading
+ ;; activities.
+ ;;
+ ;; Unfortunately on NT we can't rely on the process sentinel being called
+ ;; so we have to explicitly test the process status.
+ ;;
+ (while (bufferp (aref (clearcase-vprop-get-properties viewtag) 3))
+ (message "Reading activity list...")
+ (save-excursion
+ (set-buffer (aref (clearcase-vprop-get-properties viewtag) 3))
+ (if (or (not (processp clearcase-vprop-async-proc))
+ (eq 'exit (process-status clearcase-vprop-async-proc)))
+
+ ;; The process has finished or gone away and apparently
+ ;; the sentinel didn't get called which would have called
+ ;; clearcase-vprop-finish-reading-activities, so call it
+ ;; explicitly here.
+ ;;
+ (clearcase-vprop-finish-reading-activities (current-buffer))
+
+ ;; The process is apparently still running, so wait
+ ;; so more.
+ (setq loop-count (1+ loop-count))
+ (sit-for 1)))))
+
+ (if (not (zerop loop-count))
+ (message "Reading activity list...done"))
+
+ (aref (clearcase-vprop-get-properties viewtag) 3)))
+
+(defun clearcase-vprop-current-activity (viewtag)
+ "For VIEWTAG, return its \"current-activity\" ClearCase property."
+ (aref (clearcase-vprop-get-properties viewtag) 4))
+
+(defun clearcase-vprop-set-activities (viewtag activities)
+ "For VIEWTAG, set its \"activities\" ClearCase property to ACTIVITIES."
+ (let ((properties (clearcase-vprop-lookup-properties viewtag)))
+ ;; We must only set the activities for an existing vprop entry.
+ ;;
+ (assert properties)
+ (aset properties 3 activities)))
+
+(defun clearcase-vprop-flush-activities (viewtag)
+ "For VIEWTAG, set its \"activities\" ClearCase property to nil,
+to cause a future re-fetch."
+ (clearcase-vprop-set-activities viewtag nil))
+
+(defun clearcase-vprop-set-current-activity (viewtag activity)
+ "For VIEWTAG, set its \"current-activity\" ClearCase property to ACTIVITY."
+ (aset (clearcase-vprop-get-properties viewtag) 4 activity))
+
+;; Read the object's ClearCase properties using cleartool lsview and cleartool lsstream.
+
+(defvar clearcase-vprop-describe-count 0
+ "Count the number of times clearcase-vprop-read-properties is called")
+
+(defvar clearcase-lsstream-fmt-string
+ (if clearcase-on-mswindows
+ (if clearcase-xemacs-p
+ ;; XEmacs/Windows
+ ;;
+ (if clearcase-on-cygwin
+ ;; Cygwin build
+ ;;
+ "[\\\"%n\\\" \\\"%[master]p\\\" ]"
+ ;; Native build
+ ;;
+ "[\\\"%n\\\" \\\"%[master]p\\\" ]")
+ ;; GnuEmacs/Windows
+ ;;
+ "[\"%n\" \"%[master]p\" ]")
+ ;; Unix
+ ;;
+ "'[\"%n\" \"%[master]p\" ]'"))
+
+(defun clearcase-vprop-read-properties (viewtag)
+ "Invoke cleartool commands to obtain the ClearCase
+properties of VIEWTAG."
+
+ ;; We used to use "ct+lsview -properties -full TAG", but this seemed to take
+ ;; a long time in some circumstances. It appears to be because the
+ ;; ADM_VIEW_GET_INFO RPC can take up to 60 seconds in certain circumstances
+ ;; (typically on my laptop with self-contained ClearCase region).
+
+ ;; Accordingly, since we don't really need to store snapshotness, the minimum
+ ;; we really need to discover about a view is whether it is UCM-attached. For
+ ;; this the much faster ct+lsstream suffices.
+ ;;
+ (let* ((result (make-vector 5 nil)))
+ (if (not clearcase-v3)
+ (let ((ucm nil)
+ (stream nil)
+ (pvob nil)
+ (activity-names nil)
+ (activity-titles nil)
+ (activities nil)
+ (current-activity nil)
+ (ret ""))
+
+ ;; This was necessary to make sure the "done" message was always
+ ;; displayed. Not quite sure why.
+ ;;
+ (unwind-protect
+ (progn
+ (message "Reading view properties...")
+ (setq ret (clearcase-ct-blocking-call "lsstream" "-fmt"
+ clearcase-lsstream-fmt-string
+ "-view" viewtag))
+
+ (setq clearcase-vprop-describe-count (1+ clearcase-vprop-describe-count))
+
+ (if (setq ucm (not (zerop (length ret))))
+
+ ;; It's apparently a UCM view
+ ;;
+ (let* ((first-read (read-from-string (clearcase-utl-escape-backslashes ret)))
+ (array-read (car first-read))
+ (bytes-read (cdr first-read)))
+
+ ;; Get stream name
+ ;;
+ (setq stream (aref array-read 0))
+
+ ;; Get PVOB tag from something like "unix@/vobs/projects"
+ ;;
+ (let ((s (aref array-read 1)))
+ (if (string-match "@" s)
+ (setq pvob (substring s (match-end 0)))
+ (setq pvob s)))
+
+ ;; Get the activity list and store as a list of (NAME . TITLE) pairs
+ ;;
+ (setq activities (clearcase-vprop-read-activities-asynchronously viewtag))
+
+ ;; Get the current activity
+ ;;
+ (let ((name-string (clearcase-ct-blocking-call "lsact" "-cact" "-fmt" "%n"
+ "-view" viewtag)))
+ (if (not (zerop (length name-string)))
+ (setq current-activity name-string)))
+
+ (aset result 0 ucm)
+ (aset result 1 stream)
+ (aset result 2 pvob)
+ (aset result 3 activities)
+ (aset result 4 current-activity))))
+
+ (message "Reading view properties...done"))))
+
+ result))
+
+(defvar clearcase-vprop-async-viewtag nil)
+(defvar clearcase-vprop-async-proc nil)
+(defun clearcase-vprop-read-activities-asynchronously (viewtag)
+ (let ((buf-name (format "*clearcase-activities-%s*" viewtag)))
+ ;; Clean up old instance of the buffer we use to fetch activities:
+ ;;
+ (let ((buf (get-buffer buf-name)))
+ (if buf
+ (progn
+ (save-excursion
+ (set-buffer buf)
+ (if (and (boundp 'clearcase-vprop-async-proc)
+ clearcase-vprop-async-proc)
+ (condition-case nil
+ (kill-process clearcase-vprop-async-proc)
+ (error nil))))
+ (kill-buffer buf))))
+
+ ;; Create a buffer and an associated new process to read activities in the
+ ;; background. We return the buffer to be stored in the activities field of
+ ;; the view-properties record. The function clearcase-vprop-activities will
+ ;; recognise when the asynch fetching is still underway and wait for it to
+ ;; finish.
+ ;;
+ ;; The process has a sentinel function which is supposed to get called when
+ ;; the process finishes. This sometimes doesn't happen on Windows, so that
+ ;; clearcase-vprop-activities has to do a bit more work. (Perhaps a race
+ ;; exists: the process completes before the sentinel can be set ?)
+ ;;
+ (let* ((buf (get-buffer-create buf-name))
+ (proc (start-process (format "*clearcase-activities-process-%s*" viewtag)
+ buf
+ clearcase-cleartool-path
+ "lsact" "-view" viewtag)))
+ (process-kill-without-query proc)
+ (save-excursion
+ (set-buffer buf)
+ ;; Create a sentinel to parse and store the activities when the
+ ;; process finishes. We record the viewtag as a buffer-local
+ ;; variable so the sentinel knows where to store the activities.
+ ;;
+ (set (make-local-variable 'clearcase-vprop-async-viewtag) viewtag)
+ (set (make-local-variable 'clearcase-vprop-async-proc) proc)
+ (set-process-sentinel proc 'clearcase-vprop-read-activities-sentinel))
+ ;; Return the buffer.
+ ;;
+ buf)))
+
+(defun clearcase-vprop-read-activities-sentinel (process event-string)
+ (clearcase-trace "Activity reading process sentinel called")
+ (if (not (equal "finished\n" event-string))
+ ;; Failure
+ ;;
+ (error "Reading activities failed: %s" event-string))
+ (clearcase-vprop-finish-reading-activities (process-buffer process)))
+
+(defun clearcase-vprop-finish-reading-activities (buffer)
+ (let ((activity-list nil))
+ (message "Parsing view activities...")
+ (save-excursion
+ (set-buffer buffer)
+ (if (or (not (boundp 'clearcase-vprop-async-viewtag))
+ (null clearcase-vprop-async-viewtag))
+ (error "Internal error: clearcase-vprop-async-viewtag not set"))
+
+ ;; Check that our buffer is the one currently expected to supply the
+ ;; activities. (Avoid races.)
+ ;;
+ (let ((properties (clearcase-vprop-lookup-properties clearcase-vprop-async-viewtag)))
+ (if (and properties
+ (eq buffer (aref properties 3)))
+ (progn
+
+ ;; Parse the buffer, slicing out the 2nd and 4th fields as name and title.
+ ;;
+ (goto-char (point-min))
+ (while (re-search-forward "^[^ \t]+[ \t]+\\([^ \t]+\\)[ \t]+[^ \t]+[ \t]+\"+\\(.*\\)\"$" nil t)
+ (let ((id (buffer-substring (match-beginning 1)
+ (match-end 1)))
+ (title (buffer-substring (match-beginning 2)
+ (match-end 2))))
+ (setq activity-list (cons (cons id title)
+ activity-list))))
+
+ ;; We've got activity-list in the reverse order that
+ ;; cleartool+lsactivity generated them. I think this is reverse
+ ;; chronological order, so keep this order since it is more
+ ;; convenient when setting to an activity.
+ ;;
+ ;;(setq activity-list (nreverse activity-list))
+
+ (clearcase-vprop-set-activities clearcase-vprop-async-viewtag activity-list))
+
+ (kill-buffer buffer))))
+ (message "Parsing view activities...done")))
+
+;;{{{ old synchronous activity reader
+
+;; (defun clearcase-vprop-read-activities-synchronously (viewtag)
+;; "Return a list of (activity-name . title) pairs for VIEWTAG"
+;; ;; nyi: ought to use a variant of clearcase-ct-blocking-call that returns a buffer
+;; ;; rather than a string
+
+;; ;; Performance: takes around 30 seconds to read 1000 activities.
+;; ;; Too slow to invoke willy-nilly on integration streams for example,
+;; ;; which typically can have 1000+ activities.
+
+;; (let ((ret (clearcase-ct-blocking-call "lsact" "-view" viewtag)))
+;; (let ((buf (get-buffer-create "*clearcase-temp-activities*"))
+;; (activity-list nil))
+;; (save-excursion
+;; (set-buffer buf)
+;; (erase-buffer)
+;; (insert ret)
+;; (goto-char (point-min))
+;; ;; Slice out the 2nd and 4th fields as name and title
+;; ;;
+;; (while (re-search-forward "^[^ \t]+[ \t]+\\([^ \t]+\\)[ \t]+[^ \t]+[ \t]+\"+\\(.*\\)\"$" nil t)
+;; (setq activity-list (cons (cons (buffer-substring (match-beginning 1)
+;; (match-end 1))
+;; (buffer-substring (match-beginning 2)
+;; (match-end 2)))
+;; activity-list)))
+;; (kill-buffer buf))
+
+;; ;; We've got activity-list in the reverse order that
+;; ;; cleartool+lsactivity generated them. I think this is reverse
+;; ;; chronological order, so keep this order since it is more
+;; ;; convenient when setting to an activity.
+;; ;;
+;; ;;(nreverse activity-list))))
+;; activity-list)))
+
+;;}}}
+
+;;}}}
+
+;;{{{ Determining if a checkout was modified.
+
+;; How to tell if a file changed since checkout ?
+;;
+;; In the worst case we actually run "ct diff -pred" but we attempt several
+;; less expensive tests first.
+;;
+;; 1. If it's size differs from pred.
+;; 2. The mtime and the ctime are no longer the same.
+;;
+;; nyi: Other cheaper tests we could use:
+;;
+;; (a) After each Emacs-driven checkout go and immediately fetch the mtime of
+;; the file and store as fprop-checkout-mtime. Then use that to compare
+;; against current mtime. This at least would make this function work
+;; right on files checked out by the current Emacs process.
+;;
+;; (b) In the MVFS, after each Emacs-driven checkout go and immediately fetch
+;; the OID and store as fprop-checkout-oid. Then use that to compare
+;; against the current oid (the MVFS assigns a new OID at each write).
+;; This might not always be a win since we'd still need to run cleartool
+;; to get the current OID.
+
+(defun clearcase-file-appears-modified-since-checkout-p (file)
+ "Return whether FILE appears to have been modified since checkout.
+It doesn't examine the file contents."
+
+ (if (not (clearcase-fprop-checked-out file))
+ nil
+
+ (let ((mvfs (clearcase-file-is-in-mvfs-p file)))
+
+ ;; We consider various cases in order of increasing cost to compute.
+
+ (cond
+ ;; Case 1: (MVFS only) the size is different to its predecessor.
+ ;;
+ ((and mvfs
+ (not
+ (equal
+ (clearcase-utl-file-size file)
+ ;; nyi: For the snapshot case it'd be nice to get the size of the
+ ;; predecessor by using "ct+desc -pred -fmt" but there doesn't
+ ;; seem to be a format descriptor for file size. On the other hand
+ ;; ct+dump can obtain the size.
+ ;;
+ (clearcase-utl-file-size (clearcase-vxpath-cons-vxpath
+ file
+ (clearcase-fprop-predecessor-version
+ file)))))
+ ;; Return:
+ ;;
+ 'size-changed))
+
+ ;; Case 2: (MVFS only) the mtime and the ctime are no longer the same.
+ ;;
+ ;; nyi: At least on Windows there seems to be a small number of seconds
+ ;; difference here even when the file is not modified.
+ ;; So we really check to see of they are close.
+ ;;
+ ;; nyi: This doesn't work in a snapshot view.
+ ;;
+ ((and mvfs
+ (not (clearcase-utl-filetimes-close (clearcase-utl-file-mtime file)
+ (clearcase-utl-file-ctime file)
+ 5))
+ ;; Return:
+ ;;
+ 'ctime-mtime-not-close))
+
+ (t
+ ;; Case 3: last resort. Actually run a diff against predecessor.
+ ;;
+ (let ((ret (clearcase-ct-blocking-call "diff"
+ "-options"
+ "-quiet"
+ "-pred"
+ file)))
+ (if (not (zerop (length ret)))
+ ;; Return:
+ ;;
+ 'diffs-nonempty
+
+ ;; Return:
+ ;;
+ nil)))))))
+
+;;}}}
+
+;;{{{ Tests for view-residency
+
+;;{{{ Tests for MVFS file residency
+
+;; nyi: probably superseded by clearcase-file-would-be-in-view-p
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; nyi: this should get at least partially invalidated when
+;; VOBs are unmounted.
+
+;; nyi: make this different for NT
+;;
+(defvar clearcase-always-mvfs-regexp (if (not clearcase-on-mswindows)
+ "^/vobs/[^/]+/"
+
+ ;; nyi: express this using drive variable
+ ;;
+ (concat "^"
+ "[Mm]:"
+ clearcase-pname-sep-regexp)))
+
+;; This prevents the clearcase-file-vob-root function from pausing for long periods
+;; stat-ing /net/host@@
+;;
+;; nyi: is there something equivalent on NT I need to avoid ?
+;;
+
+(defvar clearcase-never-mvfs-regexps (if clearcase-on-mswindows
+ nil
+ '(
+ "^/net/[^/]+/"
+ "^/tmp_mnt/net/[^/]+/"
+ ))
+ "Regexps matching those paths we can assume are never inside the MVFS.")
+
+(defvar clearcase-known-vob-root-cache nil)
+
+(defun clearcase-file-would-be-in-mvfs-p (filename)
+ "Return whether FILE, after it is created, would reside in an MVFS filesystem."
+ (let ((truename (file-truename filename)))
+ (if (file-exists-p truename)
+ (clearcase-file-is-in-mvfs-p truename)
+ (let ((containing-dir (file-name-as-directory (file-name-directory truename))))
+ (clearcase-file-is-in-mvfs-p containing-dir)))))
+
+(defun clearcase-file-is-in-mvfs-p (filename)
+ "Return whether existing FILE, resides in an MVFS filesystem."
+ (let ((truename (file-truename filename)))
+
+ (or
+ ;; case 1: its prefix matches an "always VOB" prefix like /vobs/...
+ ;;
+ ;; nyi: problem here: we return true for "/vobs/nonexistent/"
+ ;;
+ (numberp (string-match clearcase-always-mvfs-regexp truename))
+
+ ;; case 2: it has a prefix which is a known VOB-root
+ ;;
+ (clearcase-file-matches-vob-root truename clearcase-known-vob-root-cache)
+
+ ;; case 3: it has an ancestor dir which is a newly met VOB-root
+ ;;
+ (clearcase-file-vob-root truename))))
+
+(defun clearcase-wd-is-in-mvfs ()
+ "Return whether the current directory resides in an MVFS filesystem."
+ (clearcase-file-is-in-mvfs-p (file-truename ".")))
+
+(defun clearcase-file-matches-vob-root (truename vob-root-list)
+ "Return whether TRUENAME has a prefix in VOB-ROOT-LIST."
+ (if (null vob-root-list)
+ nil
+ (or (numberp (string-match (regexp-quote (car vob-root-list))
+ truename))
+ (clearcase-file-matches-vob-root truename (cdr vob-root-list)))))
+
+(defun clearcase-file-vob-root (truename)
+ "File the highest versioned directory in TRUENAME."
+
+ ;; Use known non-MVFS patterns to rule some paths out.
+ ;;
+ (if (apply (function clearcase-utl-or-func)
+ (mapcar (function (lambda (regexp)
+ (string-match regexp truename)))
+ clearcase-never-mvfs-regexps))
+ nil
+ (let ((previous-dir nil)
+ (dir (file-name-as-directory (file-name-directory truename)))
+ (highest-versioned-directory nil))
+
+ (while (not (string-equal dir previous-dir))
+ (if (clearcase-file-covers-element-p dir)
+ (setq highest-versioned-directory dir))
+ (setq previous-dir dir)
+ (setq dir (file-name-directory (directory-file-name dir))))
+
+ (if highest-versioned-directory
+ (add-to-list 'clearcase-known-vob-root-cache highest-versioned-directory))
+
+ highest-versioned-directory)))
+
+;; Note: you should probably be using clearcase-fprop-mtype instead of this
+;; unless you really know what you're doing (nyi: check usages of this.)
+;;
+(defun clearcase-file-covers-element-p (path)
+ "Determine quickly if PATH refers to a Clearcase element,
+without caching the result."
+
+ ;; nyi: Even faster: consult the fprop cache first ?
+
+ (let ((element-dir (concat (clearcase-vxpath-element-part path) clearcase-vxpath-glue)))
+ (and (file-exists-p path)
+ (file-directory-p element-dir))))
+
+;;}}}
+
+;;{{{ Tests for snapshot view residency
+
+;; nyi: probably superseded by clearcase-file-would-be-in-view-p
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defvar clearcase-known-snapshot-root-cache nil)
+
+(defun clearcase-file-would-be-in-snapshot-p (filename)
+ "Return whether FILE, after it is created, would reside in a snapshot view.
+If so, return the viewtag."
+ (let ((truename (file-truename filename)))
+ (if (file-exists-p truename)
+ (clearcase-file-is-in-snapshot-p truename)
+ (let ((containing-dir (file-name-as-directory (file-name-directory truename))))
+ (clearcase-file-is-in-snapshot-p containing-dir)))))
+
+(defun clearcase-file-is-in-snapshot-p (truename)
+ "Return whether existing FILE, resides in a snapshot view.
+If so, return the viewtag."
+
+ (or
+ ;; case 1: it has a prefix which is a known snapshot-root
+ ;;
+ (clearcase-file-matches-snapshot-root truename clearcase-known-snapshot-root-cache)
+
+ ;; case 2: it has an ancestor dir which is a newly met VOB-root
+ ;;
+ (clearcase-file-snapshot-root truename)))
+
+(defun clearcase-wd-is-in-snapshot ()
+ "Return whether the current directory resides in a snapshot view."
+ (clearcase-file-is-in-snapshot-p (file-truename ".")))
+
+(defun clearcase-file-matches-snapshot-root (truename snapshot-root-list)
+ "Return whether TRUENAME has a prefix in SNAPSHOT-ROOT-LIST."
+ (if (null snapshot-root-list)
+ nil
+ (or (numberp (string-match (regexp-quote (car snapshot-root-list))
+ truename))
+ (clearcase-file-matches-snapshot-root truename (cdr snapshot-root-list)))))
+
+;; This prevents the clearcase-file-snapshot-root function from pausing for long periods
+;; stat-ing /net/host@@
+;;
+;; nyi: is there something equivalent on NT I need to avoid ?
+;;
+
+(defvar clearcase-never-snapshot-regexps (if clearcase-on-mswindows
+ nil
+ '(
+ "^/net/[^/]+/"
+ "^/tmp_mnt/net/[^/]+/"
+ ))
+ "Regexps matching those paths we can assume are never inside a snapshot view.")
+
+(defun clearcase-file-snapshot-root (truename)
+ "File the the snapshot view root containing TRUENAME."
+
+ ;; Use known non-snapshot patterns to rule some paths out.
+ ;;
+ (if (apply (function clearcase-utl-or-func)
+ (mapcar (function (lambda (regexp)
+ (string-match regexp truename)))
+ clearcase-never-snapshot-regexps))
+ nil
+ (let ((previous-dir nil)
+ (dir (file-name-as-directory (file-name-directory truename)))
+ (viewtag nil)
+ (viewroot nil))
+
+
+ (while (and (not (string-equal dir previous-dir))
+ (null viewtag))
+
+ ;; See if .view.dat exists and contains a valid view uuid
+ ;;
+ (let ((view-dat-name (concat dir (if clearcase-on-mswindows
+ "view.dat" ".view.dat"))))
+ (if (file-readable-p view-dat-name)
+ (let ((uuid (clearcase-viewdat-to-uuid view-dat-name)))
+ (if uuid
+ (progn
+ (setq viewtag (clearcase-view-uuid-to-tag uuid))
+ (if viewtag
+ (setq viewroot dir)))))))
+
+ (setq previous-dir dir)
+ (setq dir (file-name-directory (directory-file-name dir))))
+
+ (if viewroot
+ (add-to-list 'clearcase-known-snapshot-root-cache viewroot))
+
+ ;; nyi: update a viewtag==>viewroot map ?
+
+ viewroot)))
+
+(defun clearcase-viewdat-to-uuid (file)
+ "Extract the view-uuid from a .view.dat file."
+ ;; nyi, but return non-nil so clearcase-file-snapshot-root works
+ t
+ )
+
+(defun clearcase-view-uuid-to-tag (uuid)
+ "Look up the view-uuid in the register to discover its tag."
+ ;; nyi, but return non-nil so clearcase-file-snapshot-root works
+ t
+ )
+
+;;}}}
+
+;; This is simple-minded but seems to work because cleartool+describe
+;; groks snapshot views.
+;;
+;; nyi: Might be wise to cache view-roots to speed this up because the
+;; filename-handlers call this.
+;;
+;; nyi: Some possible shortcuts
+;; 1. viewroot-relative path [syntax]
+;; 2. under m:/ on NT [syntax]
+;; 3. setviewed on Unix [find a containing VOB-root]
+;; 4. subst-ed view on NT (calling net use seems very slow though)
+;; [find a containing VOB-root]
+;; 5. snapshot view
+;;
+(defun clearcase-file-would-be-in-view-p (filename)
+ "Return whether FILE, after it is created, would reside in a ClearCase view."
+ (let ((truename (file-truename (expand-file-name filename))))
+
+ ;; We use clearcase-path-file-really-exists-p here to make sure we are dealing
+ ;; with a real file and not something faked by Emacs' file name handlers
+ ;; like Ange-FTP.
+ ;;
+ (if (clearcase-path-file-really-exists-p truename)
+ (clearcase-file-is-in-view-p truename)
+ (let ((containing-dir (file-name-as-directory (file-name-directory truename))))
+ (and (clearcase-path-file-really-exists-p containing-dir)
+ (clearcase-file-is-in-view-p containing-dir))))))
+
+(defun clearcase-file-is-in-view-p (filename)
+ (let ((truename (file-truename (expand-file-name filename))))
+ ;; Shortcut if the file is a version-extended path.
+ ;;
+ (or (clearcase-file-snapshot-root truename)
+ (clearcase-vxpath-p truename)
+ (clearcase-fprop-mtype truename)
+
+ ;; nyi: How to efficiently know if we're in a dynamic-view root
+ ;; 1. Test each contained name for elementness.
+ ;; Too inefficient.
+ ;; 2. If it is viewroot-relative.
+ ;; Okay but not sufficient.
+ ;; How about case v:/ when view is substed ?
+ ;; 3. We're setviewed.
+ ;; Okay but not sufficient.
+ ;; Maintain a cache of viewroots ?
+ )))
+
+(defun clearcase-file-viewtag (filename)
+ "Find the viewtag associated with existing FILENAME."
+
+ (clearcase-when-debugging
+ (assert (file-exists-p filename)))
+
+ (let ((truename (file-truename (expand-file-name filename))))
+ (cond
+
+ ;; Case 1: viewroot-relative path
+ ;; ==> syntax
+ ;;
+ ((clearcase-vrpath-p truename)
+ (clearcase-vrpath-viewtag truename))
+
+ ;; Case 2: under m:/ on NT
+ ;; ==> syntax
+ ;;
+ ((and clearcase-on-mswindows
+ (string-match (concat clearcase-viewroot-drive
+ clearcase-pname-sep-regexp
+ "\\("
+ clearcase-non-pname-sep-regexp "*"
+ "\\)"
+ )
+ truename))
+ (substring truename (match-beginning 1) (match-end 1)))
+
+ ;; Case 3: setviewed on Unix
+ ;; ==> read EV, but need to check it's beneath a VOB-root
+ ;;
+ ((and clearcase-setview-viewtag
+ (clearcase-file-would-be-in-mvfs-p truename))
+ clearcase-setview-viewtag)
+
+ ;; Case 4: subst-ed view on NT
+ ;; ==> use ct+pwv -wdview
+ ;; Case 5: snapshot view
+ ;; ==> use ct+pwv -wdview
+ (t
+ (clearcase-file-wdview truename)))))
+
+(defun clearcase-file-wdview (truename)
+ "Return the working-directory view associated with TRUENAME,
+or nil if none"
+ (let ((default-directory (if (file-directory-p truename)
+ truename
+ (file-name-directory truename))))
+ (clearcase-ct-cd default-directory)
+ (let ((ret (clearcase-ct-blocking-call "pwv" "-wdview" "-short")))
+ (if (not (string-match " NONE " ret))
+ (clearcase-utl-1st-line-of-string ret)))))
+
+;;}}}
+
+;;{{{ The cleartool sub-process
+
+;; We use pipes rather than pty's for two reasons:
+;;
+;; 1. NT only has pipes
+;; 2. On Solaris there appeared to be a problem in the pty handling part
+;; of Emacs, which resulted in Emacs/tq seeing too many cleartool prompt
+;; strings. This would occasionally occur and prevent the tq-managed
+;; interactions with the cleartool sub-process from working correctly.
+;;
+;; Now we use pipes. Cleartool detects the "non-tty" nature of the output
+;; device and doesn't send a prompt. We manufacture an end-of-transaction
+;; marker by sending a "pwd -h" after each cleartool sub-command and then use
+;; the expected output of "Usage: pwd\n" as our end-of-txn pattern for tq.
+;;
+;; Even using pipes, the semi-permanent outboard-process using tq doesn't work
+;; well on NT. There appear to be bugs in accept-process-output such that:
+;; 0. there apparently were hairy race conditions, which a sprinkling
+;; of (accept-process-output nil 1) seemed to avoid somewhat.
+;; 1. it never seems to timeout if you name a process as arg1.
+;; 2. it always seems to wait for TIMEOUT, even if there is output ready.
+;; The result seemed to be less responsive tha just calling a fresh cleartool
+;; process for each invocation of clearcase-ct-blocking-call
+;;
+;; It still seems worthwhile to make it work on NT, as clearcase-ct-blocking-call
+;; typically takes about 0.5 secs on NT versus 0.05 sec on Solaris,
+;; an order of magnitude difference.
+;;
+
+(defconst clearcase-ct-eotxn-cmd "pwd -h\n")
+(defconst clearcase-ct-eotxn-response "Usage: pwd\n")
+(defconst clearcase-ct-eotxn-response-length (length clearcase-ct-eotxn-response))
+
+(defconst clearcase-ct-subproc-timeout 30
+ "Timeout on calls to subprocess")
+
+(defvar clearcase-ct-tq nil
+ "Transaction queue to talk to ClearTool in a subprocess")
+
+(defvar clearcase-ct-return nil
+ "Return value when we're involved in a blocking call")
+
+(defvar clearcase-ct-view ""
+ "Current view of cleartool subprocess, or the empty string if none")
+
+(defvar clearcase-ct-wdir ""
+ "Current working directory of cleartool subprocess,
+or the empty string if none")
+
+(defvar clearcase-ct-running nil)
+
+(defun clearcase-ct-accept-process-output (proc timeout)
+ (accept-process-output proc timeout))
+
+(defun clearcase-ct-start-cleartool ()
+ (interactive)
+ (clearcase-trace "clearcase-ct-start-cleartool()")
+ (let ((process-environment (append '("ATRIA_NO_BOLD=1"
+ "ATRIA_FORCE_GUI=1")
+ ;;; emacs is a GUI, right? :-)
+ process-environment)))
+ (clearcase-trace (format "Starting cleartool in %s" default-directory))
+ (let* ( ;; Force the use of a pipe
+ ;;
+ (process-connection-type nil)
+ (cleartool-process
+ (start-process "cleartool" ;; Absolute path won't work here
+ " *cleartool*"
+ clearcase-cleartool-path)))
+ (process-kill-without-query cleartool-process)
+ (setq clearcase-ct-view "")
+ (setq clearcase-ct-tq (tq-create cleartool-process))
+ (tq-enqueue clearcase-ct-tq
+ clearcase-ct-eotxn-cmd ;; question
+ clearcase-ct-eotxn-response ;; regexp
+ 'clearcase-ct-running ;; closure
+ 'set) ;; function
+ (while (not clearcase-ct-running)
+ (message "waiting for cleartool to start...")
+ (clearcase-ct-accept-process-output (tq-process clearcase-ct-tq)
+ clearcase-ct-subproc-timeout))
+ ;; Assign a sentinel to restart it if it dies.
+ ;; nyi: This needs debugging.
+ ;;(set-process-sentinel cleartool-process 'clearcase-ct-sentinel)
+
+ (clearcase-trace "clearcase-ct-start-cleartool() done")
+ (message "waiting for cleartool to start...done"))))
+
+;; nyi: needs debugging.
+;;
+(defun clearcase-ct-sentinel (process event-string)
+ (clearcase-trace (format "Cleartool process sentinel called: %s" event-string))
+ (if (not (eq 'run (process-status process)))
+ (progn
+ ;; Restart the dead cleartool.
+ ;;
+ (clearcase-trace "Cleartool process restarted")
+ (clearcase-ct-start-cleartool))))
+
+(defun clearcase-ct-kill-cleartool ()
+ "Kill off cleartool subprocess. If another one is needed,
+it will be restarted. This may be useful if you're debugging clearcase."
+ (interactive)
+ (clearcase-ct-kill-tq))
+
+(defun clearcase-ct-callback (arg val)
+ (clearcase-trace (format "clearcase-ct-callback:<\n"))
+ (clearcase-trace val)
+ (clearcase-trace (format "clearcase-ct-callback:>\n"))
+ ;; This can only get called when the last thing received from
+ ;; the cleartool sub-process was clearcase-ct-eotxn-response,
+ ;; so it is safe to just remove it here.
+ ;;
+ (setq clearcase-ct-return (substring val 0 (- clearcase-ct-eotxn-response-length))))
+
+(defun clearcase-ct-do-cleartool-command (command file comment &optional extra-args)
+ "Execute a cleartool command, notifying user and checking for
+errors. Output from COMMAND goes to buffer *clearcase*. The last argument of the
+command is the name of FILE; this is appended to an optional list of
+EXTRA-ARGS."
+
+ (if file
+ (setq file (expand-file-name file)))
+ (if (listp command)
+ (error "command must not be a list"))
+ (if clearcase-command-messages
+ (if file
+ (message "Running %s on %s..." command file)
+ (message "Running %s..." command)))
+ (let ((camefrom (current-buffer))
+ (squeezed nil)
+ status)
+ (set-buffer (get-buffer-create "*clearcase*"))
+ (setq buffer-read-only nil)
+ (erase-buffer)
+ (set (make-local-variable 'clearcase-parent-buffer) camefrom)
+ (set (make-local-variable 'clearcase-parent-buffer-name)
+ (concat " from " (buffer-name camefrom)))
+
+ ;; This is so that command arguments typed in the *clearcase* buffer will
+ ;; have reasonable defaults.
+ ;;
+ (if file
+ (setq default-directory (file-name-directory file)))
+
+ (mapcar
+ (function (lambda (s)
+ (and s
+ (not (zerop (length s)))
+ (setq squeezed
+ (append squeezed (list s))))))
+ extra-args)
+
+ (clearcase-with-tempfile
+ comment-file
+ (if (not (eq comment 'unused))
+ (if comment
+ (progn
+ (write-region comment nil comment-file nil 'noprint)
+ (setq squeezed (append squeezed (list "-cfile" (clearcase-path-native comment-file)))))
+ (setq squeezed (append squeezed (list "-nc")))))
+ (if file
+ (setq squeezed (append squeezed (list (clearcase-path-native file)))))
+ (let ((default-directory (file-name-directory
+ (or file default-directory))))
+ (clearcase-ct-cd default-directory)
+ (if clearcase-command-messages
+ (message "Running %s..." command))
+ (insert
+ (apply 'clearcase-ct-cleartool-cmd (append (list command) squeezed)))
+ (if clearcase-command-messages
+ (message "Running %s...done" command))))
+
+ (goto-char (point-min))
+ (clearcase-view-mode 0 camefrom)
+ (set-buffer-modified-p nil) ; XEmacs - fsf uses `not-modified'
+ (if (re-search-forward "^cleartool: Error:.*$" nil t)
+ (progn
+ (setq status (buffer-substring (match-beginning 0) (match-end 0)))
+ (clearcase-port-view-buffer-other-window "*clearcase*")
+ (shrink-window-if-larger-than-buffer)
+ (error "Running %s...FAILED (%s)" command status))
+ (if clearcase-command-messages
+ (message "Running %s...OK" command)))
+ (set-buffer camefrom)
+ status))
+
+(defun clearcase-ct-cd (dir)
+ (if (or (not dir)
+ (string= dir clearcase-ct-wdir))
+ clearcase-ct-wdir
+ (clearcase-ct-blocking-call "cd" (clearcase-path-native dir))
+ (setq clearcase-ct-wdir dir)))
+
+(defun clearcase-ct-cleartool-cmd (&rest cmd)
+ (apply 'clearcase-ct-blocking-call cmd))
+
+;; NT Emacs - needs a replacement for tq.
+;;
+(defun clearcase-ct-get-command-stdout (program &rest args)
+ "Call PROGRAM.
+Returns PROGRAM's stdout.
+ARGS is the command line arguments to PROGRAM."
+ (let ((buf (get-buffer-create "cleartoolexecution")))
+ (prog1
+ (save-excursion
+ (set-buffer buf)
+ (apply 'call-process program nil buf nil args)
+ (buffer-string))
+ (kill-buffer buf))))
+
+;; The TQ interaction still doesn't work on NT.
+;;
+(defvar clearcase-disable-tq clearcase-on-mswindows
+ "Set to T if the Emacs/cleartool interactions via tq are not working right.")
+
+(defun clearcase-ct-blocking-call (&rest cmd)
+ (clearcase-trace (format "clearcase-ct-blocking-call(%s)" cmd))
+ (save-excursion
+ (setq clearcase-ct-return nil)
+
+ (if clearcase-disable-tq
+ ;; Don't use tq:
+ ;;
+ (setq clearcase-ct-return (apply 'clearcase-ct-get-command-stdout
+ clearcase-cleartool-path cmd))
+
+ ;; Use tq:
+ ;;
+ (setq clearcase-ct-return nil)
+ (if (not clearcase-ct-tq)
+ (clearcase-ct-start-cleartool))
+ (unwind-protect
+ (let ((command ""))
+ (mapcar
+ (function
+ (lambda (token)
+ ;; If the token has imbedded spaces and is not already quoted,
+ ;; add double quotes.
+ ;;
+ (setq command (concat command
+ " "
+ (clearcase-utl-quote-if-nec token)))))
+ cmd)
+ (tq-enqueue clearcase-ct-tq
+ (concat command "\n"
+ clearcase-ct-eotxn-cmd) ;; question
+ clearcase-ct-eotxn-response ;; regexp
+ nil ;; closure
+ 'clearcase-ct-callback) ;; function
+ (while (not clearcase-ct-return)
+ (clearcase-ct-accept-process-output (tq-process clearcase-ct-tq)
+ clearcase-ct-subproc-timeout)))
+ ;; Error signalled:
+ ;;
+ (while (tq-queue clearcase-ct-tq)
+ (tq-queue-pop clearcase-ct-tq)))))
+ (if (string-match "cleartool: Error:" clearcase-ct-return)
+ (error "cleartool process error %s: "
+ (substring clearcase-ct-return (match-end 0))))
+ (clearcase-trace (format "command-result(%s)" clearcase-ct-return))
+ clearcase-ct-return)
+
+(defun clearcase-ct-kill-tq ()
+ (setq clearcase-ct-running nil)
+ (setq clearcase-ct-tq nil)
+ (process-send-eof (tq-process clearcase-ct-tq))
+ (kill-process (tq-process clearcase-ct-tq)))
+
+(defun clearcase-ct-kill-buffer-hook ()
+
+ ;; NT Emacs - doesn't use tq.
+ ;;
+ (if (not clearcase-on-mswindows)
+ (let ((kill-buffer-hook nil))
+ (if (and (boundp 'clearcase-ct-tq)
+ clearcase-ct-tq
+ (eq (current-buffer) (tq-buffer clearcase-ct-tq)))
+ (error "Don't kill TQ buffer %s, use `clearcase-ct-kill-tq'" (current-buffer))))))
+
+(add-hook 'kill-buffer-hook 'clearcase-ct-kill-buffer-hook)
+
+;;}}}
+
+;;{{{ Invoking a command
+
+;; nyi Would be redundant if we didn't need it to invoke normal-diff-program
+
+(defun clearcase-do-command (okstatus command file &optional extra-args)
+ "Execute a version-control command, notifying user and checking for errors.
+The command is successful if its exit status does not exceed OKSTATUS.
+Output from COMMAND goes to buffer *clearcase*. The last argument of the command is
+an optional list of EXTRA-ARGS."
+ (setq file (expand-file-name file))
+ (if clearcase-command-messages
+ (message "Running %s on %s..." command file))
+ (let ((camefrom (current-buffer))
+ (pwd )
+ (squeezed nil)
+ status)
+ (set-buffer (get-buffer-create "*clearcase*"))
+ (setq buffer-read-only nil)
+ (erase-buffer)
+ (set (make-local-variable 'clearcase-parent-buffer) camefrom)
+ (set (make-local-variable 'clearcase-parent-buffer-name)
+ (concat " from " (buffer-name camefrom)))
+ ;; This is so that command arguments typed in the *clearcase* buffer will
+ ;; have reasonable defaults.
+ ;;
+ (setq default-directory (file-name-directory file)
+ file (file-name-nondirectory file))
+
+ (mapcar
+ (function (lambda (s)
+ (and s
+ (not (zerop (length s)))
+ (setq squeezed
+ (append squeezed (list s))))))
+ extra-args)
+ (setq squeezed (append squeezed (list file)))
+ (setq status (apply 'call-process command nil t nil squeezed))
+ (goto-char (point-min))
+ (clearcase-view-mode 0 camefrom)
+ (set-buffer-modified-p nil) ; XEmacs - fsf uses `not-modified'
+ (if (or (not (integerp status)) (< okstatus status))
+ (progn
+ (clearcase-port-view-buffer-other-window "*clearcase*")
+ (shrink-window-if-larger-than-buffer)
+ (error "Running %s...FAILED (%s)" command
+ (if (integerp status)
+ (format "status %d" status)
+ status)))
+ (if clearcase-command-messages
+ (message "Running %s...OK" command)))
+ (set-buffer camefrom)
+ status))
+
+;;}}}
+
+;;{{{ Viewtag management
+
+;;{{{ Started views
+
+(defun clearcase-viewtag-try-to-start-view (viewtag)
+ "If VIEW is not apparently already visible under viewroot, start it."
+ (if (not (member viewtag (clearcase-viewtag-started-viewtags)))
+ (clearcase-viewtag-start-view viewtag)))
+
+(defun clearcase-viewtag-started-viewtags-alist ()
+ "Return an alist of views that are currently visible under the viewroot."
+ (mapcar
+ (function
+ (lambda (tag)
+ (list (concat tag "/"))))
+ (clearcase-viewtag-started-viewtags)))
+
+(defun clearcase-viewtag-started-viewtags ()
+ "Return the list of viewtags already visible under the viewroot."
+ (let ((raw-list (if clearcase-on-mswindows
+ (directory-files clearcase-viewroot-drive)
+ (directory-files clearcase-viewroot))))
+ (clearcase-utl-list-filter
+ (function (lambda (string)
+ ;; Exclude the ones that start with ".",
+ ;; and the ones that end with "@@".
+ ;;
+ (and (not (equal ?. (aref string 0)))
+ (not (string-match "@@$" string)))))
+ raw-list)))
+
+;; nyi: Makes sense on NT ?
+;; Probably also want to run subst ?
+;; Need a better high-level interface to start-view
+;;
+(defun clearcase-viewtag-start-view (viewtag)
+ "If VIEWTAG is in our cache of valid view names, start it."
+ (if (clearcase-viewtag-exists viewtag)
+ (progn
+ (message "Starting view server for %s..." viewtag)
+ (clearcase-ct-blocking-call "startview" viewtag)
+ (message "Starting view server for %s...done" viewtag))))
+
+;;}}}
+
+;;{{{ All views
+
+;;{{{ Internals
+
+(defvar clearcase-viewtag-cache nil
+ "Oblist of all known viewtags.")
+
+(defvar clearcase-viewtag-dir-cache nil
+ "Oblist of all known viewtag dirs.")
+
+(defvar clearcase-viewtag-cache-timeout 1800
+ "*Default timeout of all-viewtag cache, in seconds.")
+
+(defun clearcase-viewtag-schedule-cache-invalidation ()
+ "Schedule the next invalidation of clearcase-viewtag-cache."
+ (run-at-time (format "%s sec" clearcase-viewtag-cache-timeout)
+ nil
+ (function (lambda (&rest ignore)
+ (setq clearcase-viewtag-cache nil)))
+ nil))
+;; Some primes:
+;;
+;; 1,
+;; 2,
+;; 3,
+;; 7,
+;; 17,
+;; 31,
+;; 61,
+;; 127,
+;; 257,
+;; 509,
+;; 1021,
+;; 2053,
+
+(defun clearcase-viewtag-read-all-viewtags ()
+ "Invoke ct+lsview to get all viewtags, and return an obarry containing them."
+ (message "Fetching view names...")
+ (let* ((default-directory "/")
+ (result (make-vector 1021 0))
+ (raw-views-string (clearcase-ct-blocking-call "lsview" "-short"))
+ (view-list (clearcase-utl-split-string-at-char raw-views-string ?\n)))
+ (message "Fetching view names...done")
+ (mapcar (function (lambda (string)
+ (set (intern string result) t)))
+ view-list)
+ result))
+
+(defun clearcase-viewtag-populate-caches ()
+ (setq clearcase-viewtag-cache (clearcase-viewtag-read-all-viewtags))
+ (let ((dir-cache (make-vector 1021 0)))
+ (mapatoms
+ (function (lambda (sym)
+ (set (intern (concat (symbol-name sym) "/") dir-cache) t)))
+ clearcase-viewtag-cache)
+ (setq clearcase-viewtag-dir-cache dir-cache))
+ (clearcase-viewtag-schedule-cache-invalidation))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;}}}
+
+;; Exported interfaces
+
+;; This is for completion of viewtags.
+;;
+(defun clearcase-viewtag-all-viewtags-obarray ()
+ "Return an obarray of all valid viewtags as of the last time we looke d."
+ (if (null clearcase-viewtag-cache)
+ (clearcase-viewtag-populate-caches))
+ clearcase-viewtag-cache)
+
+;; This is for completion of viewtag dirs, like /view/my_view_name/
+;; The trailing slash is required for compatibility with other instances
+;; of filename completion in Emacs.
+;;
+(defun clearcase-viewtag-all-viewtag-dirs-obarray ()
+ "Return an obarray of all valid viewtag directory names as of the last time we looked."
+ (if (null clearcase-viewtag-dir-cache)
+ (clearcase-viewtag-populate-caches))
+ clearcase-viewtag-dir-cache)
+
+(defun clearcase-viewtag-exists (viewtag)
+ (symbol-value (intern-soft viewtag (clearcase-viewtag-all-viewtags-obarray))))
+
+;;}}}
+
+;;}}}
+
+;;{{{ Pathnames
+
+;;{{{ Pathnames: version-extended
+
+(defun clearcase-vxpath-p (path)
+ (or (string-match (concat clearcase-vxpath-glue "/") path)
+ (string-match (concat clearcase-vxpath-glue "\\\\") path)))
+
+(defun clearcase-vxpath-element-part (vxpath)
+ "Return the element part of version-extended PATH."
+ (if (string-match clearcase-vxpath-glue vxpath)
+ (substring vxpath 0 (match-beginning 0))
+ vxpath))
+
+(defun clearcase-vxpath-version-part (vxpath)
+ "Return the version part of version-extended PATH."
+ (if (string-match clearcase-vxpath-glue vxpath)
+ (substring vxpath (match-end 0))
+ nil))
+
+(defun clearcase-vxpath-branch (vxpath)
+ "Return the branch part of a version-extended path or of a version"
+ (if (clearcase-vxpath-p vxpath)
+ (clearcase-vxpath-cons-vxpath
+ (clearcase-vxpath-element-part vxpath)
+ (file-name-directory (clearcase-vxpath-version-part vxpath)))
+ (file-name-directory vxpath)))
+
+(defun clearcase-vxpath-version (vxpath)
+ "Return the numeric version part of a version-extended path or of a version"
+ (if (clearcase-vxpath-p vxpath)
+ (file-name-nondirectory (clearcase-vxpath-version-part vxpath))
+ (file-name-nondirectory vxpath)))
+
+(defun clearcase-vxpath-cons-vxpath (file version &optional viewtag)
+ "Make a ClearCase version-extended pathname for ELEMENT's version VERSION.
+If ELEMENT is actually a version-extended pathname, substitute VERSION for
+the version included in ELEMENT. If VERSION is nil, remove the version-extended
+pathname.
+
+If optional VIEWTAG is specified, make a view-relative pathname, possibly
+replacing the existing view prefix."
+ (let* ((element (clearcase-vxpath-element-part file))
+ (glue-fmt (if (and (> (length version) 0)
+ (= (aref version 0) ?/))
+ (concat "%s" clearcase-vxpath-glue "%s")
+ (concat "%s" clearcase-vxpath-glue "/%s")))
+ (relpath (clearcase-vrpath-tail element)))
+ (if viewtag
+ (setq element (concat clearcase-viewroot "/" viewtag (or relpath element))))
+ (if version
+ (format glue-fmt element version)
+ element)))
+
+;; NYI: This should cache the predecessor version as a property
+;; of the file.
+;;
+(defun clearcase-vxpath-of-predecessor (file)
+ "Compute the version-extended pathname of the predecessor version of FILE."
+ (if (not (equal 'version (clearcase-fprop-mtype file)))
+ (error "Not a clearcase version: %s" file))
+ (let ((abs-file (expand-file-name file)))
+ (let ((ver (clearcase-utl-1st-line-of-string
+ (clearcase-ct-cleartool-cmd "describe"
+ "-pred"
+ "-short"
+ (clearcase-path-native abs-file)))))
+ (clearcase-path-canonicalise-slashes (concat
+ (clearcase-vxpath-element-part file)
+ clearcase-vxpath-glue
+ ver)))))
+
+(defun clearcase-vxpath-version-extend (file)
+ "Compute the version-extended pathname of FILE."
+ (if (not (equal 'version (clearcase-fprop-mtype file)))
+ (error "Not a clearcase version: %s" file))
+ (let ((abs-file (expand-file-name file)))
+ (clearcase-path-canonicalise-slashes
+ (clearcase-utl-1st-line-of-string
+ (clearcase-ct-cleartool-cmd "describe"
+ "-fmt"
+ (concat "%En"
+ clearcase-vxpath-glue
+ "%Vn")
+ (clearcase-path-native abs-file))))))
+
+(defun clearcase-vxpath-of-branch-base (file)
+ "Compute the version-extended pathname of the version at the branch base of FILE."
+ (let* ((file-version-path
+ (if (clearcase-fprop-checked-out file)
+ ;; If the file is checked-out, start with its predecessor version...
+ ;;
+ (clearcase-vxpath-version-extend (clearcase-vxpath-of-predecessor file))
+ ;; ...otherwise start with the file's version.
+ ;;
+ (clearcase-vxpath-version-extend file)))
+ (file-version-number (string-to-int (clearcase-vxpath-version file-version-path)))
+ (branch (clearcase-vxpath-branch file-version-path)))
+ (let* ((base-number 0)
+ (base-version-path (format "%s%d" branch base-number)))
+ (while (and (not (clearcase-file-is-in-snapshot-p base-version-path))
+ (not (file-exists-p base-version-path))
+ (< base-number file-version-number))
+ (setq base-number (1+ base-number))
+ (setq base-version-path (format "%s%d" branch base-number)))
+ base-version-path)))
+
+(defun clearcase-vxpath-version-of-branch-base (file)
+ (clearcase-vxpath-version-part (clearcase-vxpath-of-branch-base file)))
+
+(defun clearcase-vxpath-get-version-in-buffer (vxpath)
+ "Return a buffer containing the version named by VXPATH.
+Intended for use in snapshot views."
+ (let* ((temp-file (clearcase-vxpath-get-version-in-temp-file vxpath))
+ (buffer (find-file-noselect temp-file t)))
+
+ ;; XEmacs throws an error if you delete a read-only file
+ ;;
+ (if clearcase-xemacs-p
+ (if (not (file-writable-p temp-file))
+ (set-file-modes temp-file (string-to-number "666" 8))))
+
+ (delete-file temp-file)
+ buffer))
+
+(defun clearcase-vxpath-get-version-in-temp-file (vxpath)
+ "Return the name of a temporary file containing the version named by VXPATH.
+Intended for use in snapshot views."
+
+ (let ((temp-file (clearcase-utl-tempfile-name vxpath)))
+ (progn
+ (clearcase-ct-blocking-call "get"
+ "-to"
+ (clearcase-path-native temp-file)
+ (clearcase-path-native vxpath))
+ temp-file)))
+
+;;}}}
+
+;;{{{ Pathnames: viewroot-relative
+
+;; nyi: make all this work with viewroot-drive-relative files too
+
+(defun clearcase-vrpath-p (path)
+ "Return whether PATH is viewroot-relative."
+ (string-match clearcase-vrpath-regexp path))
+
+(defun clearcase-vrpath-head (vrpath)
+ "Given viewroot-relative PATH, return the prefix including the view-tag."
+ (if (string-match clearcase-vrpath-regexp vrpath)
+ (substring vrpath (match-end 0))))
+
+(defun clearcase-vrpath-tail (vrpath)
+ "Given viewroot-relative PATH, return the suffix after the view-tag."
+ (if (string-match clearcase-vrpath-regexp vrpath)
+ (substring vrpath (match-end 0))))
+
+(defun clearcase-vrpath-viewtag (vrpath)
+ "Given viewroot-relative PATH, return the view-tag."
+ (if (string-match clearcase-vrpath-regexp vrpath)
+ (substring vrpath (match-beginning 1) (match-end 1))))
+
+;; Remove useless viewtags from a pathname.
+;; e.g. if we're setviewed to view "VIEWTAG"
+;; (clearcase-path-remove-useless-viewtags "/view/VIEWTAG/PATH")
+;; ==> "PATH"
+;; (clearcase-path-remove-useless-viewtags "/view/z/view/y/PATH")
+;; ==> /view/y/"PATH"
+;;
+(defvar clearcase-multiple-viewroot-regexp
+ (concat "^"
+ clearcase-viewroot
+ clearcase-pname-sep-regexp
+ clearcase-non-pname-sep-regexp "+"
+ "\\("
+ clearcase-viewroot
+ clearcase-pname-sep-regexp
+ "\\)"
+ ))
+
+(defun clearcase-path-remove-useless-viewtags (pathname)
+ ;; Try to avoid file-name-handler recursion here:
+ ;;
+ (let ((setview-root clearcase-setview-root))
+ (if setview-root
+ ;; Append "/":
+ ;;
+ (setq setview-root (concat setview-root "/")))
+
+ (cond
+
+ ((string-match clearcase-multiple-viewroot-regexp pathname)
+ (clearcase-path-remove-useless-viewtags (substring pathname (match-beginning 1))))
+
+ ((and setview-root
+ (string= setview-root "/"))
+ pathname)
+
+ ;; If pathname has setview-root as a proper prefix,
+ ;; strip it off and recurse:
+ ;;
+ ((and setview-root
+ (< (length setview-root) (length pathname))
+ (string= setview-root (substring pathname 0 (length setview-root))))
+ (clearcase-path-remove-useless-viewtags (substring pathname (- (length setview-root) 1))))
+
+ (t
+ pathname))))
+
+;;}}}
+
+;; Don't pass the "INPLACE" parameter to subst-char-in-string here since the
+;; parameter is not necessarily a local variable (in some cases it is
+;; buffer-file-name and replacing / with \ in it wreaks havoc).
+;;
+(defun clearcase-path-canonicalise-slashes (path)
+ (if (not clearcase-on-mswindows)
+ path
+ (subst-char-in-string ?\\ ?/ path)))
+
+(defun clearcase-path-canonical (path)
+ (if (not clearcase-on-mswindows)
+ path
+ (if clearcase-on-cygwin
+ (substring (shell-command-to-string (concat "cygpath -u '" path "'")) 0 -1)
+ (subst-char-in-string ?\\ ?/ path))))
+
+(defun clearcase-path-native (path)
+ (if (not clearcase-on-mswindows)
+ path
+ (if clearcase-on-cygwin
+ (substring (shell-command-to-string (concat "cygpath -w " path)) 0 -1)
+ (subst-char-in-string ?/ ?\\ path))))
+
+(defun clearcase-path-file-really-exists-p (filename)
+ "Test if a file really exists, when all file-name handlers are disabled."
+ (let ((inhibit-file-name-operation 'file-exists-p)
+ (inhibit-file-name-handlers (mapcar
+ (lambda (pair)
+ (cdr pair))
+ file-name-handler-alist)))
+ (file-exists-p filename)))
+
+(defun clearcase-path-file-in-any-scopes (file scopes)
+ (let ((result nil)
+ (cursor scopes))
+ (while (and (null result)
+ cursor)
+ (if (clearcase-path-file-in-scope file (car cursor))
+ (setq result t))
+ (setq cursor (cdr cursor)))
+ result))
+
+
+(defun clearcase-path-file-in-scope (file scope)
+ (assert (file-name-absolute-p file))
+ (assert (file-name-absolute-p scope))
+
+ (or
+ ;; Pathnames are equal
+ ;;
+ (string= file scope)
+
+ ;; scope-qua-dir is an ancestor of file (proper string prefix)
+ ;;
+ (let ((scope-as-dir (concat scope "/")))
+ (string= scope-as-dir
+ (substring file 0 (length scope-as-dir))))))
+
+;;}}}
+
+;;{{{ Mode-line
+
+(defun clearcase-mode-line-buffer-id (filename)
+ "Compute an abbreviated version string for the mode-line.
+It will be in one of three forms: /main/NNN, or .../branchname/NNN, or DO-NAME"
+
+ (if (clearcase-fprop-checked-out filename)
+ (if (clearcase-fprop-reserved filename)
+ "RESERVED"
+ "UNRESERVED")
+ (let ((ver-string (clearcase-fprop-version filename)))
+ (if (not (zerop (length ver-string)))
+ (let ((i (length ver-string))
+ (slash-count 0))
+ ;; Search back from the end to the second-last slash
+ ;;
+ (while (and (> i 0)
+ (< slash-count 2))
+ (if (equal ?/ (aref ver-string (1- i)))
+ (setq slash-count (1+ slash-count)))
+ (setq i (1- i)))
+ (if (> i 0)
+ (concat "..." (substring ver-string i))
+ (substring ver-string i)))))))
+
+;;}}}
+
+;;{{{ Minibuffer reading
+
+;;{{{ clearcase-read-version-name
+
+(defun clearcase-read-version-name (prompt file)
+ "Display PROMPT and read a version string for FILE in the minibuffer,
+with completion if possible."
+ (let* ((insert-default-directory nil)
+ (predecessor (clearcase-fprop-predecessor-version file))
+ (default-filename (clearcase-vxpath-cons-vxpath file predecessor))
+
+ ;; To get this to work it is necessary to make Emacs think
+ ;; we're completing with respect to "ELEMENT@@/" rather
+ ;; than "ELEMENT@@". Otherwise when we enter a version
+ ;; like "/main/NN", it thinks we entered an absolute path.
+ ;; So instead, we prompt the user to enter "main/..../NN"
+ ;; and add back the leading slash before returning.
+ ;;
+ (completing-dir (concat file "@@/")))
+ (if (and (clearcase-file-is-in-mvfs-p file) (not clearcase-on-mswindows))
+ ;; Completion only works in MVFS:
+ ;;
+ (concat "/" (read-file-name prompt
+ completing-dir
+ (substring predecessor 1)
+ ;;nil
+ t
+ (substring predecessor 1)))
+ (concat "/" (read-string prompt
+ (substring predecessor 1)
+ nil)))))
+
+;;}}}
+
+;;{{{ clearcase-read-label-name
+
+;; nyi: unused
+
+(defun clearcase-read-label-name (prompt)
+ "Read a label name."
+
+ (let* ((string (clearcase-ct-cleartool-cmd "lstype"
+ "-kind"
+ "lbtype"
+ "-short"))
+ labels)
+ (mapcar (function (lambda (arg)
+ (if (string-match "(locked)" arg)
+ nil
+ (setq labels (cons (list arg) labels)))))
+ (clearcase-utl-split-string string "\n"))
+ (completing-read prompt labels nil t)))
+
+;;}}}
+
+;;}}}
+
+;;{{{ Directory-tree walking
+
+(defun clearcase-dir-all-files (func &rest args)
+ "Invoke FUNC f ARGS on each regular file f in default directory."
+ (let ((dir default-directory))
+ (message "Scanning directory %s..." dir)
+ (mapcar (function (lambda (f)
+ (let ((dirf (expand-file-name f dir)))
+ (apply func dirf args))))
+ (directory-files dir))
+ (message "Scanning directory %s...done" dir)))
+
+(defun clearcase-file-tree-walk-internal (file func args quiet)
+ (if (not (file-directory-p file))
+ (apply func file args)
+ (or quiet
+ (message "Traversing directory %s..." file))
+ (let ((dir (file-name-as-directory file)))
+ (mapcar
+ (function
+ (lambda (f) (or
+ (string-equal f ".")
+ (string-equal f "..")
+ (member f clearcase-directory-exclusion-list)
+ (let ((dirf (concat dir f)))
+ (or
+ (file-symlink-p dirf) ;; Avoid possible loops
+ (clearcase-file-tree-walk-internal dirf func args quiet))))))
+ (directory-files dir)))))
+;;
+(defun clearcase-file-tree-walk (func &rest args)
+ "Walk recursively through default directory.
+Invoke FUNC f ARGS on each non-directory file f underneath it."
+ (clearcase-file-tree-walk-internal default-directory func args nil)
+ (message "Traversing directory %s...done" default-directory))
+
+(defun clearcase-subdir-tree-walk (func &rest args)
+ "Walk recursively through default directory.
+Invoke FUNC f ARGS on each subdirectory underneath it."
+ (clearcase-subdir-tree-walk-internal default-directory func args nil)
+ (message "Traversing directory %s...done" default-directory))
+
+(defun clearcase-subdir-tree-walk-internal (file func args quiet)
+ (if (file-directory-p file)
+ (let ((dir (file-name-as-directory file)))
+ (apply func dir args)
+ (or quiet
+ (message "Traversing directory %s..." file))
+ (mapcar
+ (function
+ (lambda (f) (or
+ (string-equal f ".")
+ (string-equal f "..")
+ (member f clearcase-directory-exclusion-list)
+ (let ((dirf (concat dir f)))
+ (or
+ (file-symlink-p dirf) ;; Avoid possible loops
+ (clearcase-subdir-tree-walk-internal dirf
+ func
+ args
+ quiet))))))
+ (directory-files dir)))))
+
+;;}}}
+
+;;{{{ Buffer context
+
+;; nyi: it would be nice if we could restore fold context too, for folded files.
+
+;; Save a bit of the text around POSN in the current buffer, to help
+;; us find the corresponding position again later. This works even
+;; if all markers are destroyed or corrupted.
+;;
+(defun clearcase-position-context (posn)
+ (list posn
+ (buffer-size)
+ (buffer-substring posn
+ (min (point-max) (+ posn 100)))))
+
+;; Return the position of CONTEXT in the current buffer, or nil if we
+;; couldn't find it.
+;;
+(defun clearcase-find-position-by-context (context)
+ (let ((context-string (nth 2 context)))
+ (if (equal "" context-string)
+ (point-max)
+ (save-excursion
+ (let ((diff (- (nth 1 context) (buffer-size))))
+ (if (< diff 0) (setq diff (- diff)))
+ (goto-char (nth 0 context))
+ (if (or (search-forward context-string nil t)
+ ;; Can't use search-backward since the match may continue
+ ;; after point.
+ ;;
+ (progn (goto-char (- (point) diff (length context-string)))
+ ;; goto-char doesn't signal an error at
+ ;; beginning of buffer like backward-char would.
+ ;;
+ (search-forward context-string nil t)))
+ ;; to beginning of OSTRING
+ ;;
+ (- (point) (length context-string))))))))
+
+;;}}}
+
+;;{{{ Synchronizing buffers with disk
+
+(defun clearcase-sync-after-file-updated-from-vob (file)
+ ;; Do what is needed after a file in a snapshot is updated or a checkout is
+ ;; cancelled.
+
+ ;; "ct+update" will not always make the file readonly, if, for
+ ;; example, its contents didn't actually change. But we'd like
+ ;; update to result in a readonly file, so force it here.
+ ;;
+ (clearcase-utl-make-unwriteable file)
+
+ (or
+ ;; If this returns true, there was a buffer visiting the file and it it
+ ;; flushed fprops...
+ ;;
+ (clearcase-sync-from-disk-if-needed file)
+
+ ;; ...otherwise, just sync this other state:
+ ;;
+ (progn
+ (clearcase-fprop-unstore-properties file)
+ (dired-relist-file file))))
+
+(defun clearcase-sync-from-disk (file &optional no-confirm)
+
+ (clearcase-fprop-unstore-properties file)
+ ;; If the given file is in any buffer, revert it.
+ ;;
+ (let ((buffer (find-buffer-visiting file)))
+ (if buffer
+ (save-excursion
+ (set-buffer buffer)
+ (clearcase-buffer-revert no-confirm)
+ (clearcase-fprop-get-properties file)
+
+ ;; Make sure the mode-line gets updated.
+ ;;
+ (setq clearcase-mode
+ (concat " ClearCase:"
+ (clearcase-mode-line-buffer-id file)))
+ (force-mode-line-update))))
+
+ ;; Update any Dired Mode buffers that list this file.
+ ;;
+ (dired-relist-file file)
+
+ ;; If the file was a directory, update any dired-buffer for
+ ;; that directory.
+ ;;
+ (mapcar (function (lambda (buffer)
+ (save-excursion
+ (set-buffer buffer)
+ (revert-buffer))))
+ (dired-buffers-for-dir file)))
+
+(defun clearcase-sync-from-disk-if-needed (file)
+
+ ;; If the buffer on FILE is out of sync with its file, synch it. Returns t if
+ ;; clearcase-sync-from-disk is called.
+
+ (let ((buffer (find-buffer-visiting file)))
+ (if (and buffer
+ ;; Buffer can be out of sync in two ways:
+ ;; (a) Buffer is modified (hasn't been written)
+ ;; (b) Buffer is recording a different modtime to what the file has.
+ ;; This is what happens when the file is updated by another
+ ;; process.
+ ;; (c) Buffer and file differ in their writeability.
+ ;;
+ (or (buffer-modified-p buffer)
+ (not (verify-visited-file-modtime buffer))
+ (eq (file-writable-p file)
+ (with-current-buffer buffer buffer-read-only))))
+ (progn
+ (clearcase-sync-from-disk file
+ ;; Only confirm for modified buffers.
+ ;;
+ (not (buffer-modified-p buffer)))
+ t)
+ nil)))
+
+
+(defun clearcase-sync-to-disk (&optional not-urgent)
+
+ ;; Make sure the current buffer and its working file are in sync
+ ;; NOT-URGENT means it is ok to continue if the user says not to save.
+ ;;
+ (if (buffer-modified-p)
+ (if (or clearcase-suppress-confirm
+ (y-or-n-p (format "Buffer %s modified; save it? "
+ (buffer-name))))
+ (save-buffer)
+ (if not-urgent
+ nil
+ (error "Aborted")))))
+
+
+(defun clearcase-buffer-revert (&optional no-confirm)
+ ;; Should never call for Dired buffers
+ ;;
+ (assert (not (eq major-mode 'dired-mode)))
+
+ ;; Revert buffer, try to keep point and mark where user expects them in spite
+ ;; of changes because of expanded version-control key words. This is quite
+ ;; important since otherwise typeahead won't work as expected.
+ ;;
+ (widen)
+ (let ((point-context (clearcase-position-context (point)))
+
+ ;; Use clearcase-utl-mark-marker to avoid confusion in transient-mark-mode.
+ ;; XEmacs - mark-marker t, FSF Emacs - mark-marker.
+ ;;
+ (mark-context (if (eq (marker-buffer (clearcase-utl-mark-marker))
+ (current-buffer))
+ (clearcase-position-context (clearcase-utl-mark-marker))))
+ (camefrom (current-buffer)))
+
+ ;; nyi: Should we run font-lock ?
+ ;; Want to avoid re-doing a buffer that is already correct, such as on
+ ;; check-in/check-out.
+ ;; For now do-nothing.
+
+ ;; The actual revisit.
+ ;; For some reason, revert-buffer doesn't recompute whether View Minor Mode
+ ;; should be on, so turn it off and then turn it on if necessary.
+ ;;
+ ;; nyi: Perhaps we should re-find-file ?
+ ;;
+ (or clearcase-xemacs-p
+ (if (fboundp 'view-mode)
+ (view-mode 0)))
+ (revert-buffer t no-confirm t)
+ (or clearcase-xemacs-p
+ (if (and (boundp 'view-read-only)
+ view-read-only
+ buffer-read-only)
+ (view-mode 1)))
+
+ ;; Restore point and mark.
+ ;;
+ (let ((new-point (clearcase-find-position-by-context point-context)))
+ (if new-point
+ (goto-char new-point))
+ (if mark-context
+ (let ((new-mark (clearcase-find-position-by-context mark-context)))
+ (if new-mark
+ (set-mark new-mark))))
+
+ ;; Restore a semblance of folded state.
+ ;;
+ (if (and (boundp 'folded-file)
+ folded-file)
+ (progn
+ (folding-open-buffer)
+ (folding-whole-buffer)
+ (if new-point
+ (folding-goto-char new-point)))))))
+
+;;}}}
+
+;;{{{ Utilities
+
+;;{{{ Displaying content in special buffers
+
+(defun clearcase-utl-populate-and-view-buffer (buffer
+ args
+ content-generating-func)
+ "Empty BUFFER, and populate it by applying to ARGS the CONTENT-GENERATING-FUNC,
+and display in a separate window."
+
+ (clearcase-utl-edit-and-view-buffer
+ buffer
+ (list args)
+ (function
+ (lambda (args)
+ (erase-buffer)
+ (apply content-generating-func args)))))
+
+(defun clearcase-utl-edit-and-view-buffer (buffer
+ args
+ content-editing-func)
+ "Empty BUFFER, and edit it by applying to ARGS the CONTENT-EDITING-FUNC,
+and display in a separate window."
+
+ (let ( ;; Create the buffer if necessary.
+ ;;
+ (buf (get-buffer-create buffer))
+
+ ;; Record where we came from.
+ ;;
+ (camefrom (current-buffer)))
+
+ (set-buffer buf)
+ (clearcase-view-mode 0 camefrom)
+
+ ;; Edit the buffer.
+ ;;
+ (apply content-editing-func args)
+
+ ;; Display the buffer.
+ ;;
+ (clearcase-port-view-buffer-other-window buf)
+ (goto-char 0)
+ (set-buffer-modified-p nil) ; XEmacs - fsf uses `not-modified'
+ (shrink-window-if-larger-than-buffer)))
+
+;;}}}
+
+;;{{{ Temporary files
+
+(defvar clearcase-tempfiles nil)
+(defun clearcase-utl-tempfile-name (&optional vxpath)
+ (let ((ext ""))
+ (and vxpath
+ (save-match-data
+ (if (string-match "\\(\\.[^.]+\\)@@" vxpath)
+ (setq ext (match-string 1 vxpath)))))
+ (let ((filename (concat
+ (make-temp-name (clearcase-path-canonical
+ ;; Use TEMP e.v. if set.
+ ;;
+ (concat (or (getenv "TEMP") "/tmp")
+ "/clearcase-")))
+ ext)))
+ ;; Store its name for later cleanup.
+ ;;
+ (setq clearcase-tempfiles (cons filename clearcase-tempfiles))
+ filename)))
+
+(defun clearcase-utl-clean-tempfiles ()
+ (mapcar (function
+ (lambda (tempfile)
+ (if (file-exists-p tempfile)
+ (condition-case nil
+ (delete-file tempfile)
+ (error nil)))))
+ clearcase-tempfiles)
+ (setq clearcase-tempfiles nil))
+
+;;}}}
+
+(defun clearcase-utl-touch-file (file)
+ "Attempt to update the modtime of FILE. Return t if it worked."
+ (zerop
+ ;; Silently fail if there is no "touch" command available. Couldn't find a
+ ;; convenient way to update a file's modtime in ELisp.
+ ;;
+ (condition-case nil
+ (prog1
+ (shell-command (concat "touch " file))
+ (message ""))
+ (error nil))))
+
+(defun clearcase-utl-filetimes-close (filetime1 filetime2 tolerance)
+ "Test if FILETIME1 and FILETIME2 are within TOLERANCE of each other."
+ ;; nyi: To do this correctly we need to know MAXINT.
+ ;; For now this is correct enough since we only use this as a guideline to
+ ;; avoid generating a diff.
+ ;;
+ (if (equal (first filetime1) (first filetime2))
+ (< (abs (- (second filetime1) (second filetime2))) tolerance)
+ nil))
+
+(defun clearcase-utl-emacs-date-to-clearcase-date (s)
+ (concat
+ (substring s 20) ;; yyyy
+ (int-to-string (clearcase-utl-month-unparse (substring s 4 7))) ;; mm
+ (substring s 8 10) ;; dd
+ "."
+ (substring s 11 13) ;; hh
+ (substring s 14 16) ;; mm
+ (substring s 17 19))) ;; ss
+
+(defun clearcase-utl-month-unparse (s)
+ (cond
+ ((string= s "Jan") 1)
+ ((string= s "Feb") 2)
+ ((string= s "Mar") 3)
+ ((string= s "Apr") 4)
+ ((string= s "May") 5)
+ ((string= s "Jun") 6)
+ ((string= s "Jul") 7)
+ ((string= s "Aug") 8)
+ ((string= s "Sep") 9)
+ ((string= s "Oct") 10)
+ ((string= s "Nov") 11)
+ ((string= s "Dec") 12)))
+
+(defun clearcase-utl-strip-trailing-slashes (name)
+ (let* ((len (length name)))
+ (while (and (> len 1)
+ (or (equal ?/ (aref name (1- len)))
+ (equal ?\\ (aref name (1- len)))))
+ (setq len (1- len)))
+ (substring name 0 len)))
+
+(defun clearcase-utl-file-size (file)
+ (nth 7 (file-attributes file)))
+(defun clearcase-utl-file-atime (file)
+ (nth 4 (file-attributes file)))
+(defun clearcase-utl-file-mtime (file)
+ (nth 5 (file-attributes file)))
+(defun clearcase-utl-file-ctime (file)
+ (nth 6 (file-attributes file)))
+
+(defun clearcase-utl-kill-view-buffer ()
+ (interactive)
+ (let ((buf (current-buffer)))
+ (delete-windows-on buf)
+ (kill-buffer buf)))
+
+(defun clearcase-utl-escape-double-quotes (s)
+ "Escape any double quotes in string S"
+ (mapconcat (function (lambda (char)
+ (if (equal ?\" char)
+ (string ?\\ char)
+ (string char))))
+ s
+ ""))
+
+(defun clearcase-utl-escape-backslashes (s)
+ "Double any backslashes in string S"
+ (mapconcat (function (lambda (char)
+ (if (equal ?\\ char)
+ "\\\\"
+ (string char))))
+ s
+ ""))
+
+(defun clearcase-utl-quote-if-nec (token)
+ "If TOKEN contains whitespace and is not already quoted,
+wrap it in double quotes."
+ (if (and (string-match "[ \t]" token)
+ (not (equal ?\" (aref token 0)))
+ (not (equal ?\' (aref token 0))))
+ (concat "\"" token "\"")
+ token))
+
+(defun clearcase-utl-or-func (&rest args)
+ "A version of `or' that can be applied to a list."
+ (let ((result nil)
+ (cursor args))
+ (while (and (null result)
+ cursor)
+ (if (car cursor)
+ (setq result t))
+ (setq cursor (cdr cursor)))
+ result))
+
+(defun clearcase-utl-any (predicate list)
+ "Returns t if PREDICATE is satisfied by any element in LIST."
+ (let ((result nil)
+ (cursor list))
+ (while (and (null result)
+ cursor)
+ (if (funcall predicate (car cursor))
+ (setq result t))
+ (setq cursor (cdr cursor)))
+ result))
+
+(defun clearcase-utl-every (predicate list)
+ "Returns t if PREDICATE is satisfied by every element in LIST."
+ (let ((result t)
+ (cursor list))
+ (while (and result
+ cursor)
+ (if (not (funcall predicate (car cursor)))
+ (setq result nil))
+ (setq cursor (cdr cursor)))
+ result))
+
+(defun clearcase-utl-list-filter (predicate list)
+ "Map PREDICATE over each element of LIST, and return a list of the elements
+that mapped to non-nil."
+ (let ((result '())
+ (cursor list))
+ (while (not (null cursor))
+ (let ((elt (car cursor)))
+ (if (funcall predicate elt)
+ (setq result (cons elt result)))
+ (setq cursor (cdr cursor))))
+ (nreverse result)))
+
+(defun clearcase-utl-elts-are-eq (l)
+ "Test if all elements of LIST are eq."
+ (if (null l)
+ t
+ (let ((head (car l))
+ (answer t))
+ (mapcar (function (lambda (elt)
+ (if (not (eq elt head))
+ (setq answer nil))))
+ (cdr l))
+ answer)))
+
+;; FSF Emacs - doesn't like parameters on mark-marker.
+;;
+(defun clearcase-utl-mark-marker ()
+ (if clearcase-xemacs-p
+ (mark-marker t)
+ (mark-marker)))
+
+(defun clearcase-utl-syslog (buf value)
+ (save-excursion
+ (let ((tmpbuf (get-buffer buf)))
+ (if (bufferp tmpbuf)
+ (progn
+ (set-buffer buf)
+ (goto-char (point-max))
+ (insert (format "%s\n" value)))))))
+
+;; Extract the first line of a string.
+;;
+(defun clearcase-utl-1st-line-of-string (s)
+ (let ((newline ?\n)
+ (len (length s))
+ (i 0))
+ (while (and (< i len)
+ (not (eq newline
+ (aref s i))))
+ (setq i (1+ i)))
+ (substring s 0 i)))
+
+(defun clearcase-utl-split-string (str pat &optional indir suffix)
+ (let ((ret nil)
+ (start 0)
+ (last (length str)))
+ (while (< start last)
+ (if (string-match pat str start)
+ (progn
+ (let ((tmp (substring str start (match-beginning 0))))
+ (if suffix (setq tmp (concat tmp suffix)))
+ (setq ret (cons (if indir (cons tmp nil)
+ tmp)
+ ret)))
+ (setq start (match-end 0)))
+ (setq start last)
+ (setq ret (cons (substring str start) ret))))
+ (nreverse ret)))
+
+(defun clearcase-utl-split-string-at-char (str char)
+ (let ((ret nil)
+ (i 0)
+ (eos (length str)))
+ (while (< i eos)
+ ;; Collect next token
+ ;;
+ (let ((token-begin i))
+ ;; Find the end
+ ;;
+ (while (and (< i eos)
+ (not (eq char (aref str i))))
+ (setq i (1+ i)))
+
+ (setq ret (cons (substring str token-begin i)
+ ret))
+ (setq i (1+ i))))
+ (nreverse ret)))
+
+
+(defun clearcase-utl-add-env (env var)
+ (catch 'return
+ (let ((a env)
+ (vname (substring var 0
+ (and (string-match "=" var)
+ (match-end 0)))))
+ (let ((vnl (length vname)))
+ (while a
+ (if (and (> (length (car a)) vnl)
+ (string= (substring (car a) 0 vnl)
+ vname))
+ (throw 'return env))
+ (setq a (cdr a)))
+ (cons var env)))))
+
+
+(defun clearcase-utl-augment-env-from-view-config-spec (old-env tag &optional add-ons)
+ (let ((newenv nil)
+ (cc-env (clearcase-misc-extract-evs-from-config-spe tag)))
+
+ ;; 1. Add-on bindings at the front:
+ ;;
+ (while add-ons
+ (setq newenv (clearcase-utl-add-env newenv (car add-ons)))
+ (setq add-ons (cdr add-ons)))
+
+ ;; 2. Then bindings defined in the config-spec:
+ ;;
+ (while cc-env
+ (setq newenv (clearcase-utl-add-env newenv (car cc-env)))
+ (setq cc-env (cdr cc-env)))
+
+ ;; 3. Lastly bindings that were in the old environment.
+ ;;
+ (while old-env
+ (setq newenv (clearcase-utl-add-env newenv (car old-env)))
+ (setq old-env (cdr old-env)))
+ newenv))
+
+(defun clearcase-utl-make-writeable (file)
+ ;; Equivalent to chmod u+w
+ ;;
+ (set-file-modes file
+ (logior #o0200 (file-modes file))))
+
+(defun clearcase-utl-make-unwriteable (file)
+ ;; Equivalent to chmod u-w
+ ;;
+ (set-file-modes file
+ (logand #o7577 (file-modes file))))
+
+;;}}}
+
+;;}}}
+
+;;{{{ Menus
+
+;; Predicate to determine if ClearCase menu items are relevant.
+;; nyi" this should disappear
+;;
+(defun clearcase-buffer-contains-version-p ()
+ "Return true if the current buffer contains a ClearCase file or directory."
+ (let ((object-name (if (eq major-mode 'dired-mode)
+ default-directory
+ buffer-file-name)))
+ (clearcase-fprop-file-is-version-p object-name)))
+
+;;{{{ clearcase-mode menu
+
+;;{{{ The contents
+
+;; This version of the menu will hide rather than grey out inapplicable entries.
+;;
+(defvar clearcase-menu-contents-minimised
+ (list "ClearCase"
+
+ ["Checkin" clearcase-checkin-current-buffer
+ :keys nil
+ :visible (clearcase-file-ok-to-checkin buffer-file-name)]
+
+ ["Edit checkout comment" clearcase-edit-checkout-comment-current-buffer
+ :keys nil
+ :visible (clearcase-file-ok-to-checkin buffer-file-name)]
+
+ ["Checkout" clearcase-checkout-current-buffer
+ :keys nil
+ :visible (clearcase-file-ok-to-checkout buffer-file-name)]
+
+ ["Hijack" clearcase-hijack-current-buffer
+ :keys nil
+ :visible (clearcase-file-ok-to-hijack buffer-file-name)]
+
+ ["Unhijack" clearcase-unhijack-current-buffer
+ :keys nil
+ :visible (clearcase-file-ok-to-unhijack buffer-file-name)]
+
+ ["Uncheckout" clearcase-uncheckout-current-buffer
+ :visible (clearcase-file-ok-to-uncheckout buffer-file-name)]
+
+ ["Find checkouts" clearcase-find-checkouts-in-current-view t]
+
+ ["Make element" clearcase-mkelem-current-buffer
+ :visible (clearcase-file-ok-to-mkelem buffer-file-name)]
+
+ "---------------------------------"
+ ["Describe version" clearcase-describe-current-buffer
+ :visible (clearcase-buffer-contains-version-p)]
+
+ ["Describe file" clearcase-describe-current-buffer
+ :visible (not (clearcase-buffer-contains-version-p))]
+
+ ["Annotate version" clearcase-annotate-current-buffer
+ :visible (clearcase-buffer-contains-version-p)]
+
+ ["Show config-spec rule" clearcase-what-rule-current-buffer
+ :visible (clearcase-buffer-contains-version-p)]
+
+ ;; nyi: enable this also when setviewed ?
+ ;;
+ ["Edit config-spec" clearcase-edcs-edit t]
+
+ "---------------------------------"
+ (list "Compare (Emacs)..."
+ ["Compare with predecessor" clearcase-ediff-pred-current-buffer
+ :keys nil
+ :visible (clearcase-buffer-contains-version-p)]
+ ["Compare with branch base" clearcase-ediff-branch-base-current-buffer
+ :keys nil
+ :visible (clearcase-buffer-contains-version-p)]
+ ["Compare with named version" clearcase-ediff-named-version-current-buffer
+ :keys nil
+ :visible (clearcase-buffer-contains-version-p)])
+ (list "Compare (GUI)..."
+ ["Compare with predecessor" clearcase-gui-diff-pred-current-buffer
+ :keys nil
+ :visible (clearcase-buffer-contains-version-p)]
+ ["Compare with branch base" clearcase-gui-diff-branch-base-current-buffer
+ :keys nil
+ :visible (clearcase-buffer-contains-version-p)]
+ ["Compare with named version" clearcase-gui-diff-named-version-current-buffer
+ :keys nil
+ :visible (clearcase-buffer-contains-version-p)])
+ (list "Compare (diff)..."
+ ["Compare with predecessor" clearcase-diff-pred-current-buffer
+ :keys nil
+ :visible (clearcase-buffer-contains-version-p)]
+ ["Compare with branch base" clearcase-diff-branch-base-current-buffer
+ :keys nil
+ :visible (clearcase-buffer-contains-version-p)]
+ ["Compare with named version" clearcase-diff-named-version-current-buffer
+ :keys nil
+ :visible (clearcase-buffer-contains-version-p)])
+ "---------------------------------"
+ ["Browse versions (dired)" clearcase-browse-vtree-current-buffer
+ :visible (clearcase-file-ok-to-browse buffer-file-name)]
+ ["Vtree browser GUI" clearcase-gui-vtree-browser-current-buffer
+ :keys nil
+ :visible (clearcase-buffer-contains-version-p)]
+ "---------------------------------"
+ (list "Update snapshot..."
+ ["Update view" clearcase-update-view
+ :keys nil
+ :visible (and (clearcase-file-is-in-view-p default-directory)
+ (not (clearcase-file-is-in-mvfs-p default-directory)))]
+ ["Update directory" clearcase-update-default-directory
+ :keys nil
+ :visible (and (clearcase-file-is-in-view-p default-directory)
+ (not (clearcase-file-is-in-mvfs-p default-directory)))]
+ ["Update this file" clearcase-update-current-buffer
+ :keys nil
+ :visible (and (clearcase-file-ok-to-checkout buffer-file-name)
+ (not (clearcase-file-is-in-mvfs-p buffer-file-name)))]
+ )
+ "---------------------------------"
+ (list "Element history..."
+ ["Element history (full)" clearcase-list-history-current-buffer
+ :keys nil
+ :visible (clearcase-buffer-contains-version-p)]
+ ["Element history (branch)" clearcase-list-history-current-buffer
+ :keys nil
+ :visible (clearcase-buffer-contains-version-p)]
+ ["Element history (me)" clearcase-list-history-current-buffer
+ :keys nil
+ :visible (clearcase-buffer-contains-version-p)])
+ "---------------------------------"
+ ["Show current activity" clearcase-ucm-describe-current-activity
+ :keys nil
+ :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
+ ["Make activity" clearcase-ucm-mkact-current-dir
+ :keys nil
+ :visible (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
+ ["Set activity..." clearcase-ucm-set-activity-current-dir
+ :keys nil
+ :visible (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
+ ["Set NO activity" clearcase-ucm-set-activity-none-current-dir
+ :keys nil
+ :visible (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
+ ["Rebase this stream" clearcase-gui-rebase
+ :keys nil
+ :visible (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
+ ["Deliver from this stream" clearcase-gui-deliver
+ :keys nil
+ :visible (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
+ "---------------------------------"
+ (list "ClearCase GUI"
+ ["ClearCase Explorer" clearcase-gui-clearexplorer
+ :keys nil
+ :visible clearcase-on-mswindows]
+ ["Project Explorer" clearcase-gui-project-explorer
+ :keys nil]
+ ["Merge Manager" clearcase-gui-merge-manager
+ :keys nil]
+ ["Snapshot View Updater" clearcase-gui-snapshot-view-updater
+ :keys nil])
+ "---------------------------------"
+
+ ;; nyi:
+ ;; Enable this when current buffer is on VOB.
+ ;;
+ ["Make branch type" clearcase-mkbrtype
+ :keys nil]
+
+ "---------------------------------"
+ ["Report Bug in ClearCase Mode" clearcase-submit-bug-report
+ :keys nil]
+
+ ["Dump internals" clearcase-dump
+ :keys nil
+ :visible (or (equal "rwhitby" (user-login-name))
+ (equal "esler" (user-login-name)))]
+
+ ["Flush caches" clearcase-flush-caches
+ :keys nil
+ :visible (or (equal "rwhitby" (user-login-name))
+ (equal "esler" (user-login-name)))]
+
+ "---------------------------------"
+ ["Customize..." (customize-group 'clearcase)
+ :keys nil]))
+
+(defvar clearcase-menu-contents
+ (list "ClearCase"
+
+ ["Checkin" clearcase-checkin-current-buffer
+ :keys nil
+ :active (clearcase-file-ok-to-checkin buffer-file-name)]
+
+ ["Edit checkout comment" clearcase-edit-checkout-comment-current-buffer
+ :keys nil
+ :active (clearcase-file-ok-to-checkin buffer-file-name)]
+
+ ["Checkout" clearcase-checkout-current-buffer
+ :keys nil
+ :active (clearcase-file-ok-to-checkout buffer-file-name)]
+
+ ["Hijack" clearcase-hijack-current-buffer
+ :keys nil
+ :active (clearcase-file-ok-to-hijack buffer-file-name)]
+
+ ["Unhijack" clearcase-unhijack-current-buffer
+ :keys nil
+ :active (clearcase-file-ok-to-unhijack buffer-file-name)]
+
+ ["Uncheckout" clearcase-uncheckout-current-buffer
+ :active (clearcase-file-ok-to-uncheckout buffer-file-name)]
+
+ ["Make element" clearcase-mkelem-current-buffer
+ :active (clearcase-file-ok-to-mkelem buffer-file-name)]
+
+ "---------------------------------"
+ ["Describe version" clearcase-describe-current-buffer
+ :active (clearcase-buffer-contains-version-p)]
+
+ ["Describe file" clearcase-describe-current-buffer
+ :active (not (clearcase-buffer-contains-version-p))]
+
+ ["Annotate version" clearcase-annotate-current-buffer
+ :keys nil
+ :active (clearcase-buffer-contains-version-p)]
+
+ ["Show config-spec rule" clearcase-what-rule-current-buffer
+ :active (clearcase-buffer-contains-version-p)]
+
+ ;; nyi: enable this also when setviewed ?
+ ;;
+ ["Edit config-spec" clearcase-edcs-edit t]
+
+ "---------------------------------"
+ (list "Compare (Emacs)..."
+ ["Compare with predecessor" clearcase-ediff-pred-current-buffer
+ :keys nil
+ :active (clearcase-buffer-contains-version-p)]
+ ["Compare with branch base" clearcase-ediff-branch-base-current-buffer
+ :keys nil
+ :active (clearcase-buffer-contains-version-p)]
+ ["Compare with named version" clearcase-ediff-named-version-current-buffer
+ :keys nil
+ :active (clearcase-buffer-contains-version-p)])
+ (list "Compare (GUI)..."
+ ["Compare with predecessor" clearcase-gui-diff-pred-current-buffer
+ :keys nil
+ :active (clearcase-buffer-contains-version-p)]
+ ["Compare with branch base" clearcase-gui-diff-branch-base-current-buffer
+ :keys nil
+ :active (clearcase-buffer-contains-version-p)]
+ ["Compare with named version" clearcase-gui-diff-named-version-current-buffer
+ :keys nil
+ :active (clearcase-buffer-contains-version-p)])
+ (list "Compare (diff)..."
+ ["Compare with predecessor" clearcase-diff-pred-current-buffer
+ :keys nil
+ :active (clearcase-buffer-contains-version-p)]
+ ["Compare with branch base" clearcase-diff-branch-base-current-buffer
+ :keys nil
+ :active (clearcase-buffer-contains-version-p)]
+ ["Compare with named version" clearcase-diff-named-version-current-buffer
+ :keys nil
+ :active (clearcase-buffer-contains-version-p)])
+ "---------------------------------"
+ ["Browse versions (dired)" clearcase-browse-vtree-current-buffer
+ :active (clearcase-file-ok-to-browse buffer-file-name)]
+ ["Vtree browser GUI" clearcase-gui-vtree-browser-current-buffer
+ :keys nil
+ :active (clearcase-buffer-contains-version-p)]
+ "---------------------------------"
+ (list "Update snapshot..."
+ ["Update view" clearcase-update-view
+ :keys nil
+ :active (and (clearcase-file-is-in-view-p default-directory)
+ (not (clearcase-file-is-in-mvfs-p default-directory)))]
+ ["Update directory" clearcase-update-default-directory
+ :keys nil
+ :active (and (clearcase-file-is-in-view-p default-directory)
+ (not (clearcase-file-is-in-mvfs-p default-directory)))]
+ ["Update this file" clearcase-update-current-buffer
+ :keys nil
+ :active (and (clearcase-file-ok-to-checkout buffer-file-name)
+ (not (clearcase-file-is-in-mvfs-p buffer-file-name)))]
+ )
+ "---------------------------------"
+ (list "Element history..."
+ ["Element history (full)" clearcase-list-history-current-buffer
+ :keys nil
+ :active (clearcase-buffer-contains-version-p)]
+ ["Element history (branch)" clearcase-list-history-current-buffer
+ :keys nil
+ :active (clearcase-buffer-contains-version-p)]
+ ["Element history (me)" clearcase-list-history-current-buffer
+ :keys nil
+ :active (clearcase-buffer-contains-version-p)])
+ "---------------------------------"
+ ["Show current activity" clearcase-ucm-describe-current-activity
+ :keys nil
+ :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
+ ["Make activity" clearcase-ucm-mkact-current-dir
+ :keys nil
+ :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
+ ["Set activity..." clearcase-ucm-set-activity-current-dir
+ :keys nil
+ :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
+ ["Set NO activity" clearcase-ucm-set-activity-none-current-dir
+ :keys nil
+ :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
+ ["Rebase this stream" clearcase-gui-rebase
+ :keys nil
+ :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
+ ["Deliver from this stream" clearcase-gui-deliver
+ :keys nil
+ :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
+ "---------------------------------"
+ (list "ClearCase GUI"
+ ["ClearCase Explorer" clearcase-gui-clearexplorer
+ :keys nil
+ :active clearcase-on-mswindows]
+ ["Project Explorer" clearcase-gui-project-explorer
+ :keys nil]
+ ["Merge Manager" clearcase-gui-merge-manager
+ :keys nil]
+ ["Snapshot View Updater" clearcase-gui-snapshot-view-updater
+ :keys nil])
+ "---------------------------------"
+
+ ;; nyi:
+ ;; Enable this when current buffer is on VOB.
+ ;;
+ ["Make branch type" clearcase-mkbrtype
+ :keys nil]
+
+ "---------------------------------"
+ ["Report Bug in ClearCase Mode" clearcase-submit-bug-report
+ :keys nil]
+
+ ["Dump internals" clearcase-dump
+ :keys nil
+ :active (or (equal "rwhitby" (user-login-name))
+ (equal "esler" (user-login-name)))]
+
+ ["Flush caches" clearcase-flush-caches
+ :keys nil
+ :active (or (equal "rwhitby" (user-login-name))
+ (equal "esler" (user-login-name)))]
+
+ "---------------------------------"
+ ["Customize..." (customize-group 'clearcase)
+ :keys nil]))
+
+(if (and clearcase-minimise-menus
+ (not clearcase-xemacs-p))
+ (setq clearcase-menu-contents clearcase-menu-contents-minimised))
+
+;;}}}1
+
+(if (>= emacs-major-version '20)
+ (progn
+ ;; Define the menu
+ ;;
+ (easy-menu-define
+ clearcase-menu
+ (list clearcase-mode-map)
+ "ClearCase menu"
+ clearcase-menu-contents)
+
+ (or clearcase-xemacs-p
+ (add-to-list 'menu-bar-final-items 'ClearCase))))
+
+;;}}}
+
+;;{{{ clearcase-dired-mode menu
+
+;;{{{ Related functions
+
+;; nyi: this probably gets run for each menu element.
+;; For better efficiency, look into using a one-pass ":filter"
+;; to construct this menu dynamically.
+
+(defun clearcase-dired-mark-count ()
+ (let ((old-point (point))
+ (count 0))
+ (goto-char (point-min))
+ (while (re-search-forward
+ (concat "^" (regexp-quote (char-to-string
+ dired-marker-char))) nil t)
+ (setq count (1+ count)))
+ (goto-char old-point)
+ count))
+
+(defun clearcase-dired-current-ok-to-checkin ()
+ (let ((file (dired-get-filename nil t)))
+ (and file
+ (clearcase-file-ok-to-checkin file))))
+
+(defun clearcase-dired-current-ok-to-checkout ()
+ (let ((file (dired-get-filename nil t)))
+ (and file
+ (clearcase-file-ok-to-checkout file))))
+
+(defun clearcase-dired-current-ok-to-uncheckout ()
+ (let ((file (dired-get-filename nil t)))
+ (and file
+ (clearcase-file-ok-to-uncheckout file))))
+
+(defun clearcase-dired-current-ok-to-hijack ()
+ (let ((file (dired-get-filename nil t)))
+ (and file
+ (clearcase-file-ok-to-hijack file))))
+
+(defun clearcase-dired-current-ok-to-unhijack ()
+ (let ((file (dired-get-filename nil t)))
+ (and file
+ (clearcase-file-ok-to-unhijack file))))
+
+(defun clearcase-dired-current-ok-to-mkelem ()
+ (let ((file (dired-get-filename nil t)))
+ (and file
+ (clearcase-file-ok-to-mkelem file))))
+
+(defun clearcase-dired-current-ok-to-browse ()
+ (let ((file (dired-get-filename nil t)))
+ (clearcase-file-ok-to-browse file)))
+
+(defvar clearcase-dired-max-marked-files-to-check 5
+ "The maximum number of marked files in a Dired buffer when constructing
+the ClearCase menu.")
+
+;; nyi: speed these up by stopping check when a non-qualifying file is found
+;; Better:
+;; - hook the menu constuction and figure out what ops apply
+;; - hook mark/unmark/move cursor
+
+(defun clearcase-dired-marked-ok-to-checkin ()
+ (let ((files (dired-get-marked-files)))
+ (or (> (length files) clearcase-dired-max-marked-files-to-check)
+ (clearcase-utl-every (function clearcase-file-ok-to-checkin)
+ files))))
+
+(defun clearcase-dired-marked-ok-to-checkout ()
+ (let ((files (dired-get-marked-files)))
+ (or (> (length files) clearcase-dired-max-marked-files-to-check)
+ (clearcase-utl-every (function clearcase-file-ok-to-checkout)
+ files))))
+
+(defun clearcase-dired-marked-ok-to-uncheckout ()
+ (let ((files (dired-get-marked-files)))
+ (or (> (length files) clearcase-dired-max-marked-files-to-check)
+ (clearcase-utl-every (function clearcase-file-ok-to-uncheckout)
+ files))))
+
+(defun clearcase-dired-marked-ok-to-hijack ()
+ (let ((files (dired-get-marked-files)))
+ (or (> (length files) clearcase-dired-max-marked-files-to-check)
+ (clearcase-utl-every (function clearcase-file-ok-to-hijack)
+ files))))
+
+(defun clearcase-dired-marked-ok-to-unhijack ()
+ (let ((files (dired-get-marked-files)))
+ (or (> (length files) clearcase-dired-max-marked-files-to-check)
+ (clearcase-utl-every (function clearcase-file-ok-to-unhijack)
+ files))))
+
+(defun clearcase-dired-marked-ok-to-mkelem ()
+ (let ((files (dired-get-marked-files)))
+ (or (> (length files) clearcase-dired-max-marked-files-to-check)
+ (clearcase-utl-every (function clearcase-file-ok-to-mkelem)
+ files))))
+
+(defun clearcase-dired-current-dir-ok-to-checkin ()
+ (let ((dir (dired-current-directory)))
+ (clearcase-file-ok-to-checkin dir)))
+
+(defun clearcase-dired-current-dir-ok-to-checkout ()
+ (let ((dir (dired-current-directory)))
+ (clearcase-file-ok-to-checkout dir)))
+
+(defun clearcase-dired-current-dir-ok-to-uncheckout ()
+ (let ((dir (dired-current-directory)))
+ (clearcase-file-ok-to-uncheckout dir)))
+
+;;}}}
+
+;;{{{ Contents
+
+;; This version of the menu will hide rather than grey out inapplicable entries.
+;;
+(defvar clearcase-dired-menu-contents-minimised
+ (list "ClearCase"
+
+ ;; Current file
+ ;;
+ ["Checkin file" clearcase-checkin-dired-files
+ :keys nil
+ :visible (and (< (clearcase-dired-mark-count) 2)
+ (clearcase-dired-current-ok-to-checkin))]
+
+ ["Edit checkout comment" clearcase-edit-checkout-comment-dired-file
+ :keys nil
+ :visible (and (< (clearcase-dired-mark-count) 2)
+ (clearcase-dired-current-ok-to-checkin))]
+
+ ["Checkout file" clearcase-checkout-dired-files
+ :keys nil
+ :visible (and (< (clearcase-dired-mark-count) 2)
+ (clearcase-dired-current-ok-to-checkout))]
+
+ ["Uncheckout file" clearcase-uncheckout-dired-files
+ :keys nil
+ :visible (and (< (clearcase-dired-mark-count) 2)
+ (clearcase-dired-current-ok-to-uncheckout))]
+
+ ["Hijack file" clearcase-hijack-dired-files
+ :keys nil
+ :visible (and (< (clearcase-dired-mark-count) 2)
+ (clearcase-dired-current-ok-to-hijack))]
+
+ ["Unhijack file" clearcase-unhijack-dired-files
+ :keys nil
+ :visible (and (< (clearcase-dired-mark-count) 2)
+ (clearcase-dired-current-ok-to-unhijack))]
+
+ ["Find checkouts" clearcase-find-checkouts-in-current-view t]
+
+ ["Make file an element" clearcase-mkelem-dired-files
+ :visible (and (< (clearcase-dired-mark-count) 2)
+ (clearcase-dired-current-ok-to-mkelem))]
+
+ ;; Marked files
+ ;;
+ ["Checkin marked files" clearcase-checkin-dired-files
+ :keys nil
+ :visible (and (>= (clearcase-dired-mark-count) 2)
+ (clearcase-dired-marked-ok-to-checkin))]
+
+ ["Checkout marked files" clearcase-checkout-dired-files
+ :keys nil
+ :visible (and (>= (clearcase-dired-mark-count) 2)
+ (clearcase-dired-marked-ok-to-checkout))]
+
+ ["Uncheckout marked files" clearcase-uncheckout-dired-files
+ :keys nil
+ :visible (and (>= (clearcase-dired-mark-count) 2)
+ (clearcase-dired-marked-ok-to-uncheckout))]
+
+ ["Hijack marked files" clearcase-hijack-dired-files
+ :keys nil
+ :visible (and (>= (clearcase-dired-mark-count) 2)
+ (clearcase-dired-marked-ok-to-hijack))]
+
+ ["Unhijack marked files" clearcase-unhijack-dired-files
+ :keys nil
+ :visible (and (>= (clearcase-dired-mark-count) 2)
+ (clearcase-dired-marked-ok-to-unhijack))]
+
+ ["Make marked files elements" clearcase-mkelem-dired-files
+ :keys nil
+ :visible (and (>= (clearcase-dired-mark-count) 2)
+ (clearcase-dired-marked-ok-to-mkelem))]
+
+
+ ;; Current directory
+ ;;
+ ["Checkin current-dir" clearcase-dired-checkin-current-dir
+ :keys nil
+ :visible (clearcase-dired-current-dir-ok-to-checkin)]
+
+ ["Checkout current dir" clearcase-dired-checkout-current-dir
+ :keys nil
+ :visible (clearcase-dired-current-dir-ok-to-checkout)]
+
+ ["Uncheckout current dir" clearcase-dired-uncheckout-current-dir
+ :keys nil
+ :visible (clearcase-dired-current-dir-ok-to-uncheckout)]
+
+ "---------------------------------"
+ ["Describe file" clearcase-describe-dired-file
+ :visible t]
+
+ ["Annotate file" clearcase-annotate-dired-file
+ :visible t]
+
+ ["Show config-spec rule" clearcase-what-rule-dired-file
+ :visible t]
+
+
+ ["Edit config-spec" clearcase-edcs-edit t]
+
+ "---------------------------------"
+ (list "Compare (Emacs)..."
+ ["Compare with predecessor" clearcase-ediff-pred-dired-file
+ :keys nil
+ :visible t]
+ ["Compare with branch base" clearcase-ediff-branch-base-dired-file
+ :keys nil
+ :visible t]
+ ["Compare with named version" clearcase-ediff-named-version-dired-file
+ :keys nil
+ :visible t])
+ (list "Compare (GUI)..."
+ ["Compare with predecessor" clearcase-gui-diff-pred-dired-file
+ :keys nil
+ :visible t]
+ ["Compare with branch base" clearcase-gui-diff-branch-base-dired-file
+ :keys nil
+ :visible t]
+ ["Compare with named version" clearcase-gui-diff-named-version-dired-file
+ :keys nil
+ :visible t])
+ (list "Compare (diff)..."
+ ["Compare with predecessor" clearcase-diff-pred-dired-file
+ :keys nil
+ :visible t]
+ ["Compare with branch base" clearcase-diff-branch-base-dired-file
+ :keys nil
+ :visible t]
+ ["Compare with named version" clearcase-diff-named-version-dired-file
+ :keys nil
+ :visible t])
+ "---------------------------------"
+ ["Browse versions (dired)" clearcase-browse-vtree-dired-file
+ :visible (clearcase-dired-current-ok-to-browse)]
+ ["Vtree browser GUI" clearcase-gui-vtree-browser-dired-file
+ :keys nil
+ :visible t]
+ "---------------------------------"
+ (list "Update snapshot..."
+ ["Update view" clearcase-update-view
+ :keys nil
+ :visible (and (clearcase-file-is-in-view-p default-directory)
+ (not (clearcase-file-is-in-mvfs-p default-directory)))]
+ ["Update directory" clearcase-update-default-directory
+ :keys nil
+ :visible (and (clearcase-file-is-in-view-p default-directory)
+ (not (clearcase-file-is-in-mvfs-p default-directory)))]
+ ["Update file" clearcase-update-dired-files
+ :keys nil
+ :visible (and (< (clearcase-dired-mark-count) 2)
+ (clearcase-dired-current-ok-to-checkout)
+ (not (clearcase-file-is-in-mvfs-p default-directory)))]
+ ["Update marked files" clearcase-update-dired-files
+ :keys nil
+ :visible (and (>= (clearcase-dired-mark-count) 2)
+ (not (clearcase-file-is-in-mvfs-p default-directory)))]
+ )
+ "---------------------------------"
+ (list "Element history..."
+ ["Element history (full)" clearcase-list-history-dired-file
+ :keys nil
+ :visible t]
+ ["Element history (branch)" clearcase-list-history-dired-file
+ :keys nil
+ :visible t]
+ ["Element history (me)" clearcase-list-history-dired-file
+ :keys nil
+ :visible t])
+ "---------------------------------"
+ ["Show current activity" clearcase-ucm-describe-current-activity
+ :keys nil
+ :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
+ ["Make activity" clearcase-ucm-mkact-current-dir
+ :keys nil
+ :visible (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
+ ["Set activity..." clearcase-ucm-set-activity-current-dir
+ :keys nil
+ :visible (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
+ ["Set NO activity" clearcase-ucm-set-activity-none-current-dir
+ :keys nil
+ :visible (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
+ ["Rebase this stream" clearcase-gui-rebase
+ :keys nil
+ :visible (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
+ ["Deliver from this stream" clearcase-gui-deliver
+ :keys nil
+ :visible (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
+ "---------------------------------"
+ (list "ClearCase GUI"
+ ["ClearCase Explorer" clearcase-gui-clearexplorer
+ :keys nil
+ :visible clearcase-on-mswindows]
+ ["Project Explorer" clearcase-gui-project-explorer
+ :keys nil]
+ ["Merge Manager" clearcase-gui-merge-manager
+ :keys nil]
+ ["Snapshot View Updater" clearcase-gui-snapshot-view-updater
+ :keys nil])
+ "---------------------------------"
+
+ ["Make branch type" clearcase-mkbrtype
+ :keys nil]
+
+ "---------------------------------"
+ ["Report Bug in ClearCase Mode" clearcase-submit-bug-report
+ :keys nil]
+
+ ["Dump internals" clearcase-dump
+ :keys nil
+ :visible (or (equal "rwhitby" (user-login-name))
+ (equal "esler" (user-login-name)))]
+
+ ["Flush caches" clearcase-flush-caches
+ :keys nil
+ :visible (or (equal "rwhitby" (user-login-name))
+ (equal "esler" (user-login-name)))]
+
+ "---------------------------------"
+ ["Customize..." (customize-group 'clearcase)
+ :keys nil]))
+
+(defvar clearcase-dired-menu-contents
+ (list "ClearCase"
+
+ ;; Current file
+ ;;
+ ["Checkin file" clearcase-checkin-dired-files
+ :keys nil
+ :active (and (< (clearcase-dired-mark-count) 2)
+ (clearcase-dired-current-ok-to-checkin))]
+
+ ["Edit checkout comment" clearcase-edit-checkout-comment-dired-file
+ :keys nil
+ :active (and (< (clearcase-dired-mark-count) 2)
+ (clearcase-dired-current-ok-to-checkin))]
+
+ ["Checkout file" clearcase-checkout-dired-files
+ :keys nil
+ :active (and (< (clearcase-dired-mark-count) 2)
+ (clearcase-dired-current-ok-to-checkout))]
+
+ ["Uncheckout file" clearcase-uncheckout-dired-files
+ :keys nil
+ :active (and (< (clearcase-dired-mark-count) 2)
+ (clearcase-dired-current-ok-to-uncheckout))]
+
+ ["Hijack file" clearcase-hijack-dired-files
+ :keys nil
+ :active (and (< (clearcase-dired-mark-count) 2)
+ (clearcase-dired-current-ok-to-hijack))]
+
+ ["Unhijack file" clearcase-unhijack-dired-files
+ :keys nil
+ :active (and (< (clearcase-dired-mark-count) 2)
+ (clearcase-dired-current-ok-to-unhijack))]
+
+ ["Make file an element" clearcase-mkelem-dired-files
+ :active (and (< (clearcase-dired-mark-count) 2)
+ (clearcase-dired-current-ok-to-mkelem))]
+
+ ;; Marked files
+ ;;
+ ["Checkin marked files" clearcase-checkin-dired-files
+ :keys nil
+ :active (and (>= (clearcase-dired-mark-count) 2)
+ (clearcase-dired-marked-ok-to-checkin))]
+
+ ["Checkout marked files" clearcase-checkout-dired-files
+ :keys nil
+ :active (and (>= (clearcase-dired-mark-count) 2)
+ (clearcase-dired-marked-ok-to-checkout))]
+
+ ["Uncheckout marked files" clearcase-uncheckout-dired-files
+ :keys nil
+ :active (and (>= (clearcase-dired-mark-count) 2)
+ (clearcase-dired-marked-ok-to-uncheckout))]
+
+ ["Hijack marked files" clearcase-hijack-dired-files
+ :keys nil
+ :active (and (>= (clearcase-dired-mark-count) 2)
+ (clearcase-dired-marked-ok-to-hijack))]
+
+ ["Unhijack marked files" clearcase-unhijack-dired-files
+ :keys nil
+ :active (and (>= (clearcase-dired-mark-count) 2)
+ (clearcase-dired-marked-ok-to-unhijack))]
+
+ ["Make marked files elements" clearcase-mkelem-dired-files
+ :keys nil
+ :active (and (>= (clearcase-dired-mark-count) 2)
+ (clearcase-dired-marked-ok-to-mkelem))]
+
+
+ ;; Current directory
+ ;;
+ ["Checkin current-dir" clearcase-dired-checkin-current-dir
+ :keys nil
+ :active (clearcase-dired-current-dir-ok-to-checkin)]
+
+ ["Checkout current dir" clearcase-dired-checkout-current-dir
+ :keys nil
+ :active (clearcase-dired-current-dir-ok-to-checkout)]
+
+ ["Uncheckout current dir" clearcase-dired-uncheckout-current-dir
+ :keys nil
+ :active (clearcase-dired-current-dir-ok-to-uncheckout)]
+
+ "---------------------------------"
+ ["Describe file" clearcase-describe-dired-file
+ :active t]
+
+ ["Annotate file" clearcase-annotate-dired-file
+ :active t]
+
+ ["Show config-spec rule" clearcase-what-rule-dired-file
+ :active t]
+
+
+ ["Edit config-spec" clearcase-edcs-edit t]
+
+ "---------------------------------"
+ (list "Compare (Emacs)..."
+ ["Compare with predecessor" clearcase-ediff-pred-dired-file
+ :keys nil
+ :active t]
+ ["Compare with branch base" clearcase-ediff-branch-base-dired-file
+ :keys nil
+ :active t]
+ ["Compare with named version" clearcase-ediff-named-version-dired-file
+ :keys nil
+ :active t])
+ (list "Compare (GUI)..."
+ ["Compare with predecessor" clearcase-gui-diff-pred-dired-file
+ :keys nil
+ :active t]
+ ["Compare with branch base" clearcase-gui-diff-branch-base-dired-file
+ :keys nil
+ :active t]
+ ["Compare with named version" clearcase-gui-diff-named-version-dired-file
+ :keys nil
+ :active t])
+ (list "Compare (diff)..."
+ ["Compare with predecessor" clearcase-diff-pred-dired-file
+ :keys nil
+ :active t]
+ ["Compare with branch base" clearcase-diff-branch-base-dired-file
+ :keys nil
+ :active t]
+ ["Compare with named version" clearcase-diff-named-version-dired-file
+ :keys nil
+ :active t])
+ "---------------------------------"
+ ["Browse versions (dired)" clearcase-browse-vtree-dired-file
+ :active (clearcase-dired-current-ok-to-browse)]
+ ["Vtree browser GUI" clearcase-gui-vtree-browser-dired-file
+ :keys nil
+ :active t]
+ "---------------------------------"
+ (list "Update snapshot..."
+ ["Update view" clearcase-update-view
+ :keys nil
+ :active (and (clearcase-file-is-in-view-p default-directory)
+ (not (clearcase-file-is-in-mvfs-p default-directory)))]
+ ["Update directory" clearcase-update-default-directory
+ :keys nil
+ :active (and (clearcase-file-is-in-view-p default-directory)
+ (not (clearcase-file-is-in-mvfs-p default-directory)))]
+ ["Update file" clearcase-update-dired-files
+ :keys nil
+ :active (and (< (clearcase-dired-mark-count) 2)
+ (clearcase-dired-current-ok-to-checkout)
+ (not (clearcase-file-is-in-mvfs-p default-directory)))]
+ ["Update marked files" clearcase-update-dired-files
+ :keys nil
+ :active (and (>= (clearcase-dired-mark-count) 2)
+ (not (clearcase-file-is-in-mvfs-p default-directory)))]
+ )
+ "---------------------------------"
+ (list "Element history..."
+ ["Element history (full)" clearcase-list-history-dired-file
+ :keys nil
+ :active t]
+ ["Element history (branch)" clearcase-list-history-dired-file
+ :keys nil
+ :active t]
+ ["Element history (me)" clearcase-list-history-dired-file
+ :keys nil
+ :active t])
+ "---------------------------------"
+ ["Show current activity" clearcase-ucm-describe-current-activity
+ :keys nil
+ :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
+ ["Make activity" clearcase-ucm-mkact-current-dir
+ :keys nil
+ :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
+ ["Set activity..." clearcase-ucm-set-activity-current-dir
+ :keys nil
+ :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
+ ["Set NO activity" clearcase-ucm-set-activity-none-current-dir
+ :keys nil
+ :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
+ ["Rebase this stream" clearcase-gui-rebase
+ :keys nil
+ :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
+ ["Deliver from this stream" clearcase-gui-deliver
+ :keys nil
+ :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
+ "---------------------------------"
+ (list "ClearCase GUI"
+ ["ClearCase Explorer" clearcase-gui-clearexplorer
+ :keys nil
+ :active clearcase-on-mswindows]
+ ["Project Explorer" clearcase-gui-project-explorer
+ :keys nil]
+ ["Merge Manager" clearcase-gui-merge-manager
+ :keys nil]
+ ["Snapshot View Updater" clearcase-gui-snapshot-view-updater
+ :keys nil])
+ "---------------------------------"
+
+ ["Make branch type" clearcase-mkbrtype
+ :keys nil]
+
+ "---------------------------------"
+ ["Report Bug in ClearCase Mode" clearcase-submit-bug-report
+ :keys nil]
+
+ ["Dump internals" clearcase-dump
+ :keys nil
+ :active (or (equal "rwhitby" (user-login-name))
+ (equal "esler" (user-login-name)))]
+
+ ["Flush caches" clearcase-flush-caches
+ :keys nil
+ :active (or (equal "rwhitby" (user-login-name))
+ (equal "esler" (user-login-name)))]
+
+ "---------------------------------"
+ ["Customize..." (customize-group 'clearcase)
+ :keys nil]))
+
+(if (and clearcase-minimise-menus
+ (not clearcase-xemacs-p))
+ (setq clearcase-dired-menu-contents clearcase-dired-menu-contents-minimised))
+
+;;}}}
+
+(if (>= emacs-major-version '20)
+ (progn
+ (easy-menu-define
+ clearcase-dired-menu
+ (list clearcase-dired-mode-map)
+ "ClearCase Dired menu"
+ clearcase-dired-menu-contents)
+
+ (or clearcase-xemacs-p
+ (add-to-list 'menu-bar-final-items 'ClearCase))))
+
+;;}}}
+
+;;}}}
+
+;;{{{ Widgets
+
+;;{{{ Single-selection buffer widget
+
+;; Keep the compiler quiet by declaring these
+;; buffer-local variables here thus.
+;;
+(defvar clearcase-selection-window-config nil)
+(defvar clearcase-selection-interpreter nil)
+(defvar clearcase-selection-continuation nil)
+(defvar clearcase-selection-operands nil)
+
+(defun clearcase-ucm-make-selection-window (buffer-name
+ buffer-contents
+ selection-interpreter
+ continuation
+ cont-arglist)
+ (let ((buf (get-buffer-create buffer-name)))
+ (save-excursion
+
+ ;; Reset the buffer
+ ;;
+ (set-buffer buf)
+ (setq buffer-read-only nil)
+ (erase-buffer)
+ (setq truncate-lines t)
+
+ ;; Paint the buffer
+ ;;
+ (goto-char (point-min))
+ (insert buffer-contents)
+
+ ;; Insert mouse-highlighting
+ ;;
+ (save-excursion
+ (goto-char (point-min))
+ (while (< (point) (point-max))
+ (condition-case nil
+ (progn
+ (beginning-of-line)
+ (put-text-property (point)
+ (save-excursion
+ (end-of-line)
+ (point))
+ 'mouse-face 'highlight))
+ (error nil))
+ (forward-line 1)))
+
+ ;; Set a keymap
+ ;;
+ (setq buffer-read-only t)
+ (use-local-map clearcase-selection-keymap)
+
+ ;; Set up the interpreter and continuation
+ ;;
+ (set (make-local-variable 'clearcase-selection-window-config)
+ (current-window-configuration))
+ (set (make-local-variable 'clearcase-selection-interpreter)
+ selection-interpreter)
+ (set (make-local-variable 'clearcase-selection-continuation)
+ continuation)
+ (set (make-local-variable 'clearcase-selection-operands)
+ cont-arglist))
+
+ ;; Display the buffer
+ ;;
+ (pop-to-buffer buf)
+ (goto-char 0)
+ (shrink-window-if-larger-than-buffer)
+ (message "Use RETURN to select an item")))
+
+(defun clearcase-selection-continue ()
+ (interactive)
+ (beginning-of-line)
+ (sit-for 0)
+ ;; Call the interpreter to extract the item of interest
+ ;; from the buffer.
+ ;;
+ (let ((item (funcall clearcase-selection-interpreter)))
+ ;; Call the continuation.
+ ;;
+ (apply clearcase-selection-continuation
+ (append clearcase-selection-operands (list item))))
+
+ ;; Restore window config
+ ;;
+ (let ((sel-buffer (current-buffer)))
+ (if clearcase-selection-window-config
+ (set-window-configuration clearcase-selection-window-config))
+ (delete-windows-on sel-buffer)
+ (kill-buffer sel-buffer)))
+
+(defun clearcase-selection-mouse-continue (click)
+ (interactive "@e")
+ (mouse-set-point click)
+ (clearcase-selection-continue))
+
+(defvar clearcase-selection-keymap
+ (let ((map (make-sparse-keymap)))
+ (define-key map [return] 'clearcase-selection-continue)
+ (define-key map [mouse-2] 'clearcase-selection-mouse-continue)
+ (define-key map "q" 'clearcase-utl-kill-view-buffer)
+ ;; nyi: refresh list
+ ;; (define-key map "g" 'clearcase-selection-get)
+ map))
+
+;;}}}
+
+;;}}}
+
+;;{{{ Integration with Emacs
+
+;;{{{ Functions: examining the ClearCase installation
+
+;; Discover ClearCase version-string
+;;
+(defun clearcase-get-version-string ()
+ ;; Some care seems to be necessary to avoid problems caused by odd settings
+ ;; of the "SHELL" environment variable. I found that simply
+ ;; (shell-command-to-string "cleartool -version") on Windows-2000 with
+ ;; SHELL==cmd.exe just returned a copy of the Windows command prompt. The
+ ;; result was that clearcase-integrate would not complete.
+ ;;
+ ;; The follow seems to work.
+ ;;
+ (if clearcase-on-mswindows
+ (shell-command-to-string "cmd /c cleartool -version")
+ (shell-command-to-string "sh -c \"cleartool -version\"")))
+
+;; Find where cleartool is installed.
+;;
+(defun clearcase-find-cleartool ()
+ "Search directories listed in the PATH environment variable
+looking for a cleartool executable. If found return the full pathname."
+ (let ((dir-list (parse-colon-path (getenv "PATH")))
+ (cleartool-name (if clearcase-on-mswindows
+ "cleartool.exe"
+ "cleartool"))
+ (cleartool-path nil))
+ (catch 'found
+ (mapcar
+ (function (lambda (dir)
+ (let ((f (expand-file-name (concat dir cleartool-name))))
+ (if (file-executable-p f)
+ (progn
+ (setq cleartool-path f)
+ (throw 'found t))))))
+ dir-list)
+ nil)
+ cleartool-path))
+
+(defun clearcase-non-lt-registry-server-online-p ()
+ "Heuristic to determine if the local host is network-connected to
+its ClearCase servers. Used for a non-LT system."
+
+ (let ((result nil)
+ (buf (get-buffer-create " *clearcase-lsregion*")))
+ (save-excursion
+ (set-buffer buf)
+ (erase-buffer)
+ (let ((process (start-process "lsregion"
+ buf
+ "cleartool"
+ "lsregion"
+ "-long"))
+ (timeout-occurred nil))
+
+ ;; Now wait a little while, if necessary, for some output.
+ ;;
+ (while (and (null result)
+ (not timeout-occurred)
+ (< (buffer-size) (length "Tag: ")))
+ (if (null (accept-process-output process 10))
+ (setq timeout-occurred t))
+ (goto-char (point-min))
+ (if (looking-at "Tag: ")
+ (setq result t)))
+ (condition-case nil
+ (kill-process process)
+ (error nil))))
+ ;; If servers are apparently not online, keep the
+ ;; buffer around so we can see what lsregion reported.
+ ;;
+ (sit-for 0.01); Fix by AJM to prevent kill-buffer claiming process still running
+ (if result
+ (kill-buffer buf))
+ result))
+
+;; We could have an LT system, which lacks ct+lsregion, but has ct+lssite.
+;;
+(defun clearcase-lt-registry-server-online-p ()
+ "Heuristic to determine if the local host is network-connected to
+its ClearCase servers. Used for LT system."
+
+ (let ((result nil)
+ (buf (get-buffer-create " *clearcase-lssite*")))
+ (save-excursion
+ (set-buffer buf)
+ (erase-buffer)
+ (let ((process (start-process "lssite"
+ buf
+ "cleartool"
+ "lssite"
+ "-inquire"))
+ (timeout-occurred nil))
+
+ ;; Now wait a little while, if necessary, for some output.
+ ;;
+ (while (and (null result)
+ (not timeout-occurred)
+ (< (buffer-size) (length " view_cache_size")))
+ (if (null (accept-process-output process 10))
+ (setq timeout-occurred t))
+ (goto-char (point-min))
+ (if (re-search-forward "view_cache_size" nil t)
+ (setq result t)))
+ (condition-case nil
+ (kill-process process)
+ (error nil))))
+
+ ;; If servers are apparently not online, keep the
+ ;; buffer around so we can see what lssite reported.
+ ;;
+ (sit-for 0.01); Fix by AJM to prevent kill-buffer claiming process still running
+ (if result
+ (kill-buffer buf))
+ result))
+
+;; Find out if the ClearCase registry server is accessible.
+;; We could be on a disconnected laptop.
+;;
+(defun clearcase-registry-server-online-p ()
+ "Heuristic to determine if the local host is network-connected to
+its ClearCase server(s)."
+
+ (if clearcase-lt
+ (clearcase-lt-registry-server-online-p)
+ (clearcase-non-lt-registry-server-online-p)))
+
+;;}}}
+;;{{{ Functions: hooks
+
+;;{{{ A find-file hook to turn on clearcase-mode
+
+(defun clearcase-hook-find-file-hook ()
+ (let ((filename (buffer-file-name)))
+ (if filename
+ (progn
+ (clearcase-fprop-unstore-properties filename)
+ (if (clearcase-file-would-be-in-view-p filename)
+ (progn
+ ;; 1. Activate minor mode
+ ;;
+ (clearcase-mode 1)
+
+ ;; 2. Pre-fetch file properties
+ ;;
+ (if (file-exists-p filename)
+ (progn
+ (clearcase-fprop-get-properties filename)
+
+ ;; 3. Put branch/ver in mode-line
+ ;;
+ (setq clearcase-mode
+ (concat " ClearCase:"
+ (clearcase-mode-line-buffer-id filename)))
+ (force-mode-line-update)
+
+ ;; 4. Schedule the asynchronous fetching of the view's properties
+ ;; next time Emacs is idle enough.
+ ;;
+ (clearcase-vprop-schedule-work (clearcase-fprop-viewtag filename))
+
+ ;; 5. Set backup policy
+ ;;
+ (unless clearcase-make-backup-files
+ (make-local-variable 'backup-inhibited)
+ (setq backup-inhibited t))))
+
+ (clearcase-set-auto-mode)))))))
+
+(defun clearcase-set-auto-mode ()
+ "Check again for the mode of the current buffer when using ClearCase version extended paths."
+
+ (let* ((version (clearcase-vxpath-version-part (buffer-file-name)))
+ (buffer-file-name (clearcase-vxpath-element-part (buffer-file-name))))
+
+ ;; Need to recheck the major mode only if a version was appended.
+ ;;
+ (if version
+ (set-auto-mode))))
+
+;;}}}
+
+;;{{{ A find-file hook for version-extended pathnames
+
+(defun clearcase-hook-vxpath-find-file-hook ()
+ (if (clearcase-vxpath-p default-directory)
+ (let ((element (clearcase-vxpath-element-part default-directory))
+ (version (clearcase-vxpath-version-part default-directory)))
+
+ ;; 1. Set the buffer name to <filename>@@/<branch path>/<version>.
+ ;;
+ (let ((new-buffer-name
+ (concat (file-name-nondirectory element)
+ clearcase-vxpath-glue
+ version
+ (buffer-name))))
+
+ (or (string= new-buffer-name (buffer-name))
+
+ ;; Uniquify the name, if necessary.
+ ;;
+ (let ((n 2)
+ (uniquifier-string ""))
+ (while (get-buffer (concat new-buffer-name uniquifier-string))
+ (setq uniquifier-string (format "<%d>" n))
+ (setq n (1+ n)))
+ (rename-buffer
+ (concat new-buffer-name uniquifier-string)))))
+
+ ;; 2. Set the default directory to the dir containing <filename>.
+ ;;
+ (let ((new-dir (file-name-directory element)))
+ (setq default-directory new-dir))
+
+ ;; 3. Disable auto-saving.
+ ;;
+ ;; If we're visiting <filename>@@/<branch path>/199
+ ;; we don't want Emacs trying to find a place to create a "#199#.
+ ;;
+ (auto-save-mode 0))))
+
+;;}}}
+
+;;{{{ A dired-mode-hook to turn on clearcase-dired-mode
+
+(defun clearcase-hook-dired-mode-hook ()
+ ;; Force a re-computation of whether the directory is within ClearCase.
+ ;;
+ (clearcase-fprop-unstore-properties default-directory)
+
+ ;; Wrap this in an exception handler. Otherwise, diredding into
+ ;; a deregistered or otherwise defective snapshot-view fails.
+ ;;
+ (condition-case nil
+ ;; If this directory is below a ClearCase element,
+ ;; 1. turn on ClearCase Dired Minor Mode.
+ ;; 2. display branch/ver in mode-line
+ ;;
+ (if (clearcase-file-would-be-in-view-p default-directory)
+ (progn
+ (if clearcase-auto-dired-mode
+ (progn
+ (clearcase-dired-mode 1)
+ (clearcase-fprop-get-properties default-directory)
+ (clearcase-vprop-schedule-work (clearcase-fprop-viewtag default-directory))))
+ (setq clearcase-dired-mode
+ (concat " ClearCase:"
+ (clearcase-mode-line-buffer-id default-directory)))
+ (force-mode-line-update)))
+ (error (message "Error fetching ClearCase properties of %s" default-directory))))
+
+;;}}}
+
+;;{{{ A dired-after-readin-hook to add ClearCase information to the display
+
+(defun clearcase-hook-dired-after-readin-hook ()
+
+ ;; If in clearcase-dired-mode, reformat the buffer.
+ ;;
+ (if clearcase-dired-mode
+ (progn
+ (clearcase-dired-reformat-buffer)
+ (if clearcase-dired-show-view
+ (clearcase-dired-insert-viewtag))))
+ t)
+
+;;}}}
+
+;;{{{ A write-file-hook to auto-insert a version-string.
+
+;; To use this, put a line containing this in the first 8 lines of your file:
+;; ClearCase-version: </main/laptop/155>
+;; and make sure that clearcase-version-stamp-active gets set to true at least
+;; locally in the file.
+
+(defvar clearcase-version-stamp-line-limit 1000)
+(defvar clearcase-version-stamp-begin-regexp "ClearCase-version:[ \t]<")
+(defvar clearcase-version-stamp-end-regexp ">")
+(defvar clearcase-version-stamp-active nil)
+
+(defun clearcase-increment-version (version-string)
+ (let* ((branch (clearcase-vxpath-branch version-string))
+ (number (clearcase-vxpath-version version-string))
+ (new-number (1+ (string-to-number number))))
+ (format "%s%d" branch new-number)))
+
+(defun clearcase-version-stamp ()
+ (interactive)
+ (if (and clearcase-mode
+ clearcase-version-stamp-active
+ (file-exists-p buffer-file-name)
+ (equal 'version (clearcase-fprop-mtype buffer-file-name)))
+ (let ((latest-version (clearcase-fprop-predecessor-version buffer-file-name)))
+
+ ;; Note: If the buffer happens to be folded, we may not find the place
+ ;; to insert the version-stamp. Folding mode really needs to supply a
+ ;; 'save-folded-excursion function to solve this one. We won't attempt
+ ;; a cheaper hack here.
+
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (forward-line clearcase-version-stamp-line-limit)
+ (let ((limit (point))
+ (v-start nil)
+ (v-end nil))
+ (goto-char (point-min))
+ (while (and (< (point) limit)
+ (re-search-forward clearcase-version-stamp-begin-regexp
+ limit
+ 'move))
+ (setq v-start (point))
+ (end-of-line)
+ (let ((line-end (point)))
+ (goto-char v-start)
+ (if (re-search-forward clearcase-version-stamp-end-regexp
+ line-end
+ 'move)
+ (setq v-end (match-beginning 0)))))
+ (if v-end
+ (let ((new-version-stamp (clearcase-increment-version latest-version)))
+ (goto-char v-start)
+ (delete-region v-start v-end)
+ (insert-and-inherit new-version-stamp)))))))))
+
+(defun clearcase-hook-write-file-hook ()
+
+ (clearcase-version-stamp)
+ ;; Important to return nil so the files eventually gets written.
+ ;;
+ nil)
+
+;;}}}
+
+;;{{{ A kill-buffer hook
+
+(defun clearcase-hook-kill-buffer-hook ()
+ (let ((filename (buffer-file-name)))
+ (if (and filename
+ ;; W3 has buffers in which 'buffer-file-name is bound to
+ ;; a URL. Don't attempt to unstore their properties.
+ ;;
+ (boundp 'buffer-file-truename)
+ buffer-file-truename)
+ (clearcase-fprop-unstore-properties filename))))
+
+;;}}}
+
+;;{{{ A kill-emacs-hook
+
+(defun clearcase-hook-kill-emacs-hook ()
+ (clearcase-utl-clean-tempfiles))
+
+;;}}}
+
+;;}}}
+;;{{{ Function: to replace toggle-read-only
+
+(defun clearcase-toggle-read-only (&optional arg)
+ "Change read-only status of current buffer, perhaps via version control.
+If the buffer is visiting a ClearCase version, then check the file in or out.
+Otherwise, just change the read-only flag of the buffer. If called with an
+argument then just change the read-only flag even if visiting a ClearCase
+version."
+ (interactive "P")
+ (cond (arg
+ (toggle-read-only))
+ ((and (clearcase-fprop-mtype buffer-file-name)
+ buffer-read-only
+ (file-writable-p buffer-file-name)
+ (/= 0 (user-uid)))
+ (toggle-read-only))
+
+ ((clearcase-fprop-mtype buffer-file-name)
+ (clearcase-next-action-current-buffer))
+
+ (t
+ (toggle-read-only))))
+
+;;}}}
+;;{{{ Functions: file-name-handlers
+
+;;{{{ Start dynamic views automatically when paths to them are used
+
+;; This handler starts views when viewroot-relative paths are dereferenced.
+;;
+;; nyi: for now really only seems useful on Unix.
+;;
+(defun clearcase-viewroot-relative-file-name-handler (operation &rest args)
+
+ (clearcase-when-debugging
+ (if (fboundp 'clearcase-utl-syslog)
+ (clearcase-utl-syslog "*clearcase-fh-trace*"
+ (cons "clearcase-viewroot-relative-file-name-handler:"
+ (cons operation args)))))
+
+ ;; Inhibit the handler to avoid recursion.
+ ;;
+ (let ((inhibit-file-name-handlers
+ (cons 'clearcase-viewroot-relative-file-name-handler
+ (and (eq inhibit-file-name-operation operation)
+ inhibit-file-name-handlers)))
+ (inhibit-file-name-operation operation))
+
+ (let ((first-arg (car args)))
+ ;; We don't always get called with a string.
+ ;; e.g. one file operation is verify-visited-file-modtime, whose
+ ;; first argument is a buffer.
+ ;;
+ (if (stringp first-arg)
+ (progn
+ ;; Now start the view if necessary
+ ;;
+ (save-match-data
+ (let* ((path (clearcase-path-remove-useless-viewtags first-arg))
+ (viewtag (clearcase-vrpath-viewtag path))
+ (default-directory (clearcase-path-remove-useless-viewtags default-directory)))
+ (if viewtag
+ (clearcase-viewtag-try-to-start-view viewtag))))))
+ (apply operation args))))
+
+;;}}}
+
+;;{{{ Completion on viewtags
+
+;; This handler provides completion for viewtags.
+;;
+(defun clearcase-viewtag-file-name-handler (operation &rest args)
+
+ (clearcase-when-debugging
+ (if (fboundp 'clearcase-utl-syslog)
+ (clearcase-utl-syslog "*clearcase-fh-trace*"
+ (cons "clearcase-viewtag-file-name-handler:"
+ (cons operation args)))))
+ (cond
+
+ ((eq operation 'file-name-completion)
+ (save-match-data (apply 'clearcase-viewtag-completion args)))
+
+ ((eq operation 'file-name-all-completions)
+ (save-match-data (apply 'clearcase-viewtag-completions args)))
+
+ (t
+ (let ((inhibit-file-name-handlers
+ (cons 'clearcase-viewtag-file-name-handler
+ (and (eq inhibit-file-name-operation operation)
+ inhibit-file-name-handlers)))
+ (inhibit-file-name-operation operation))
+ (apply operation args)))))
+
+(defun clearcase-viewtag-completion (file dir)
+ (try-completion file (clearcase-viewtag-all-viewtag-dirs-obarray)))
+
+(defun clearcase-viewtag-completions (file dir)
+ (let ((tags (all-completions file
+ (clearcase-viewtag-all-viewtags-obarray))))
+ (mapcar
+ (function (lambda (tag)
+ (concat tag "/")))
+ tags)))
+
+;;}}}
+
+;;{{{ File name handler for version extended file names
+
+;; For version extended pathnames there are two possible answers
+;; for each of
+;; file-name-directory
+;; file-name-nondirectory
+;;
+;; 1. that pertaining to the element path, e.g.
+;; (file-name-directory "DIR/FILE@@/BRANCH/VERSION")
+;; ==> "DIR/"
+;; 2. that pertaining to the version path, e.g.
+;; (file-name-directory "DIR/FILE@@/BRANCH/VERSION")
+;; ==> "DIR/FILE@@/BRANCH/"
+;;
+;; Often we'd like the former, but sometimes we'd like the latter, for example
+;; inside clearcase-browse-vtree, where it calls dired. Within dired on Gnu
+;; Emacs, it calls file-name-directory on the supplied pathname and in this
+;; case we want the version (i.e. branch) path to be used.
+;;
+;; How to get the behaviour we want ?
+
+;; APPROACH A:
+;; ==========
+;;
+;; Define a variable clearcase-treat-branches-as-dirs, which modifies
+;; the behaviour of clearcase-vxpath-file-name-handler to give answer (1).
+;;
+;; Just before we invoke dired inside clearcase-browse-vtree, dynamically
+;; bind clearcase-treat-branches-as-dirs to t. Also in the resulting Dired Mode
+;; buffer, make clearcase-treat-branches-as-dirs buffer-local and set it.
+;;
+;; Unfortunately this doesn't quite give us what we want. For example I often
+;; invoke grep from a dired buffer on a branch-qua-directory to scan all the
+;; version on that branch for a certain string. The grep-mode buffer has no
+;; buffer-local binding for clearcase-treat-branches-as-dirs so the grep
+;; command runs in "DIR/" instead of in "DIR/FILE@@/BRANCH/".
+;;
+;; APPROACH B:
+;; ==========
+;;
+;; Modify the semantics of clearcase-vxpath-file-name-handler so that
+;; if the filename given is a pathname to an existing branch-qua-directory
+;; give answer 2, otherwise give answer 1.
+;;
+;; APPROACH C:
+;; ==========
+;;
+;; Use the existence of a Dired Mode buffer on "DIR/FILE@@/BRANCH/" to
+;; change the semantics of clearcase-vxpath-file-name-handler.
+;;
+;; (A) is unsatisfactory and I'm not entirely happy with (B) nor (C) so for now
+;; I'm going to disable this filename handler until I'm more convinced it is
+;; needed.
+
+(defun clearcase-vxpath-file-name-handler (operation &rest args)
+ (clearcase-when-debugging
+ (if (fboundp 'clearcase-utl-syslog)
+ (clearcase-utl-syslog "*clearcase-fh-trace*"
+ (cons "clearcase-vxpath-file-name-handler:"
+ (cons operation args)))))
+ ;; Inhibit recursion:
+ ;;
+ (let ((inhibit-file-name-handlers
+ (cons 'clearcase-vxpath-file-name-handler
+ (and (eq inhibit-file-name-operation operation)
+ inhibit-file-name-handlers)))
+ (inhibit-file-name-operation operation))
+
+ (cond ((eq operation 'file-name-nondirectory)
+ (file-name-nondirectory (clearcase-vxpath-element-part
+ (car args))))
+
+ ((eq operation 'file-name-directory)
+ (file-name-directory (clearcase-vxpath-element-part
+ (car args))))
+
+ (t
+ (apply operation args)))))
+
+;;}}}
+
+;;}}}
+;;{{{ Advice: Disable VC in the MVFS
+
+;; This handler ensures that VC doesn't attempt to operate inside the MVFS.
+;; This stops it from futile searches for RCS directories and the like inside.
+;; It prevents a certain amount of clutter in the MVFS' noent-cache.
+;;
+
+(defadvice vc-registered (around clearcase-interceptor disable compile)
+ "Disable normal behavior if in a clearcase dynamic view.
+This is enabled/disabled by clearcase-integrate/clearcase-unintegrate."
+ (if (clearcase-file-would-be-in-view-p (ad-get-arg 0))
+ nil
+ ad-do-it))
+
+;;}}}
+
+;;{{{ Functions: integrate and un-integrate.
+
+(defun clearcase-integrate ()
+ "Enable ClearCase integration"
+ (interactive)
+
+ ;; 0. Empty caches.
+ ;;
+ (clearcase-fprop-clear-all-properties)
+ (clearcase-vprop-clear-all-properties)
+
+ ;; 1. Install hooks.
+ ;;
+ (add-hook 'find-file-hooks 'clearcase-hook-find-file-hook)
+ (add-hook 'find-file-hooks 'clearcase-hook-vxpath-find-file-hook)
+ (add-hook 'dired-mode-hook 'clearcase-hook-dired-mode-hook)
+ (add-hook 'dired-after-readin-hook 'clearcase-hook-dired-after-readin-hook)
+ (add-hook 'kill-buffer-hook 'clearcase-hook-kill-buffer-hook)
+ (add-hook 'write-file-hooks 'clearcase-hook-write-file-hook)
+ (add-hook 'kill-emacs-hook 'clearcase-hook-kill-emacs-hook)
+
+ ;; 2. Install file-name handlers.
+ ;;
+ ;; 2.1 Start views when //view/TAG or m:/TAG is referenced.
+ ;;
+ (add-to-list 'file-name-handler-alist
+ (cons clearcase-vrpath-regexp
+ 'clearcase-viewroot-relative-file-name-handler))
+
+ ;; 2.2 Completion on viewtags.
+ ;;
+ (if clearcase-complete-viewtags
+ (add-to-list 'file-name-handler-alist
+ (cons clearcase-viewtag-regexp
+ 'clearcase-viewtag-file-name-handler)))
+
+ ;; 2.3 Turn off RCS/VCS/SCCS activity inside a ClearCase dynamic view.
+ ;;
+ (if clearcase-suppress-vc-within-mvfs
+ (when clearcase-suppress-vc-within-mvfs
+ (ad-enable-advice 'vc-registered 'around 'clearcase-interceptor)
+ (ad-activate 'vc-registered)))
+
+ ;; Disabled for now. See comments above clearcase-vxpath-file-name-handler.
+ ;;
+ ;; ;; 2.4 Add file name handler for version extended path names
+ ;; ;;
+ ;; (add-to-list 'file-name-handler-alist
+ ;; (cons clearcase-vxpath-glue 'clearcase-vxpath-file-name-handler))
+ )
+
+(defun clearcase-unintegrate ()
+ "Disable ClearCase integration"
+ (interactive)
+
+ ;; 0. Empty caches.
+ ;;
+ (clearcase-fprop-clear-all-properties)
+ (clearcase-vprop-clear-all-properties)
+
+ ;; 1. Remove hooks.
+ ;;
+ (remove-hook 'find-file-hooks 'clearcase-hook-find-file-hook)
+ (remove-hook 'find-file-hooks 'clearcase-hook-vxpath-find-file-hook)
+ (remove-hook 'dired-mode-hook 'clearcase-hook-dired-mode-hook)
+ (remove-hook 'dired-after-readin-hook 'clearcase-hook-dired-after-readin-hook)
+ (remove-hook 'kill-buffer-hook 'clearcase-hook-kill-buffer-hook)
+ (remove-hook 'write-file-hooks 'clearcase-hook-write-file-hook)
+ (remove-hook 'kill-emacs-hook 'clearcase-hook-kill-emacs-hook)
+
+ ;; 2. Remove file-name handlers.
+ ;;
+ (setq file-name-handler-alist
+ (delete-if (function
+ (lambda (entry)
+ (memq (cdr entry)
+ '(clearcase-viewroot-relative-file-name-handler
+ clearcase-viewtag-file-name-handler
+ clearcase-vxpath-file-name-handler))))
+ file-name-handler-alist))
+
+ ;; 3. Turn on RCS/VCS/SCCS activity everywhere.
+ ;;
+ (ad-disable-advice 'vc-registered 'around 'clearcase-interceptor)
+ (ad-activate 'vc-registered))
+
+;;}}}
+
+;; Here's where we really wire it all in:
+;;
+(defvar clearcase-cleartool-path nil)
+(defvar clearcase-clearcase-version-installed nil)
+(defvar clearcase-lt nil)
+(defvar clearcase-v3 nil)
+(defvar clearcase-v4 nil)
+(defvar clearcase-v6 nil)
+(defvar clearcase-servers-online nil)
+(defvar clearcase-setview-root nil)
+(defvar clearcase-setview-viewtag)
+(defvar clearcase-setview-root nil)
+(defvar clearcase-setview-viewtag nil)
+
+(progn
+ ;; If the SHELL environment variable points to the wrong place,
+ ;; call-process fails on Windows and this startup fails.
+ ;; Check for this and unset the useless EV.
+
+ (let ((shell-ev-value (getenv "SHELL")))
+ (if clearcase-on-mswindows
+ (if (stringp shell-ev-value)
+ (if (not (executable-find shell-ev-value))
+ (setenv "SHELL" nil)))))
+
+ ;; Things have to be done here in a certain order.
+ ;;
+ ;; 1. Make sure cleartool is on the shell search PATH.
+ ;;
+ (if (setq clearcase-cleartool-path (clearcase-find-cleartool))
+ (progn
+ ;; 2. Try to discover what version of ClearCase we have:
+ ;;
+ (setq clearcase-clearcase-version-installed (clearcase-get-version-string))
+ (setq clearcase-lt
+ (not (null (string-match "ClearCase LT"
+ clearcase-clearcase-version-installed))))
+ (setq clearcase-v3
+ (not (null (string-match "^ClearCase version 3"
+ clearcase-clearcase-version-installed))))
+ (setq clearcase-v4
+ (not (null (string-match "^ClearCase version 4"
+ clearcase-clearcase-version-installed))))
+ (setq clearcase-v5
+ (not (null (string-match "^ClearCase \\(LT \\)?version 2002.05"
+ clearcase-clearcase-version-installed))))
+ (setq clearcase-v6
+ (not (null (string-match "^ClearCase \\(LT \\)?version 2003.06"
+ clearcase-clearcase-version-installed))))
+
+ ;; 3. Gather setview information:
+ ;;
+ (if (setq clearcase-setview-root (if (not clearcase-on-mswindows)
+ (getenv "CLEARCASE_ROOT")))
+ (setq clearcase-setview-viewtag
+ (file-name-nondirectory clearcase-setview-root)))
+
+ ;; 4. Discover if the servers appear to be online.
+ ;;
+ (setq clearcase-servers-online (clearcase-registry-server-online-p))
+
+ (if clearcase-servers-online
+
+ ;; 5. Everything seems in place to ensure that ClearCase mode will
+ ;; operate correctly, so integrate now.
+ ;;
+ (progn
+ (clearcase-integrate)
+ ;; Schedule a fetching of the view properties when next idle.
+ ;; This avoids awkward pauses after the user reaches for the
+ ;; ClearCase menubar entry.
+ ;;
+ (if clearcase-setview-viewtag
+ (clearcase-vprop-schedule-work clearcase-setview-viewtag)))))))
+
+(if (not clearcase-servers-online)
+ (message "ClearCase apparently not online. ClearCase/Emacs integration not installed."))
+
+;;}}}
+
+(provide 'clearcase)
+
+;;; clearcase.el ends here
+\f
+;; Local variables:
+;; folded-file: t
+;; clearcase-version-stamp-active: t
+;; End:
--- /dev/null
+(custom-set-variables\r
+ '(default-toolbar-position (quote right))\r
+ '(kill-whole-line t)\r
+ '(paren-mode (quote sexp) nil (paren))\r
+ '(pending-delete-mode t nil (pending-del)))\r
+(custom-set-faces\r
+ '(default ((t (:size "12pt" :family "Lucida Sans Typewriter"))) t)\r
+ '(zmacs-region ((t (:foreground "white" :background "Steelblue"))) t))\r
+\r
--- /dev/null
+(if (string-match "cygwin"
+(downcase (shell-command-to-string "uname")))
+(progn
+ (setq exec-path (cons "C:/Cygwin/bin" exec-path))
+ (setenv "PATH" (concat "C:/Cygwin/bin;" (getenv "PATH")))))
+
+(setenv "CVS_RSH" "ssh")
+
+;; NT-emacs assumes a Windows command shell, which you change here.
+(setq process-coding-system-alist '(("bash" . undecided-unix)))
+(setq w32-quote-process-args ?\")
+(setq shell-file-name "bash")
+(setenv "SHELL" shell-file-name)
+(setq explicit-shell-file-name shell-file-name)
+
+;; This removes unsightly ^M characters that would otherwise
+(add-hook 'comint-output-filter-functions
+ 'comint-strip-ctrl-m)
+(setq shell-command-switch "-cf")
+
+(global-set-key "\C-x\C-c" 'kill-buffer)
+(global-set-key "\C-x\C-n" 'save-buffers-kill-emacs)
+(global-set-key "\C-x\C-z" 'suspend-emacs-or-iconify-frame)
+
+(setq-default column-number-mode t)
+(display-time)
+(setq-default line-number-mode t)
+
+(global-set-key 'kp-tab 'tab-to-tab-stop)
+(set-default 'indent-tabs-mode t)
+(set-default 'tab-width 8)
+(c-set-offset 'substatement-open 0)
+(c-set-offset 'case-label '+)
+
+; Preload common modes
+(load-file "/usr/share/xemacs/xemacs-packages/lisp/sh-script/sh-script.el")
+(load-file "~/.xemacs/clearcase.el")
+(load-file "~/.xemacs/visual-basic-mode.el")
+(autoload 'sh-mode "sh-mode")
+(autoload 'perl-mode "perl-mode")
+(autoload 'javascript-mode "javascript-mode")
+(autoload 'visual-basic-mode "visual-basic-mode")
+
+(defvar my-c-style
+ '((c-auto-newline . nil)
+ (c-toggle-auto-state . 1)
+ (c-basic-offset . 2)
+ (c-block-comments-indent-p . t)
+ (c-comment-only-line-offset . nil)
+ (c-echo-syntactic-information-p . nil)
+ (c-hanging-comment-ender-p . t)
+ (c-recognize-knr-p . t) ; use nil if only have ANSI prototype
+ (c-tab-always-indent . t)
+ (comment-column . 40)
+ (comment-end . " */")
+ (comment-multi-line . t)
+ (comment-start . "/* ")
+ (c-hanging-comment-ender-p . nil)
+ (c-offsets-alist . ((knr-argdecl-intro . +)
+ (case-label . +)
+ (knr-argdecl . 0)
+ (label . 0)
+ (statement-case-open . +)
+ (statement-cont . +)
+ (substatement-open . 0))))
+ "my c-style for cc-mode")
+
+(add-hook 'c-mode-common-hook
+ '(lambda ()
+ (c-add-style "MINE" my-c-style)
+ (c-set-style "MINE")))
+(load-default-sounds)
+
+(load "recent-files")
+(recent-files-initialize)
+
+;; Set ftp program to use Windows FTP. Using Cygwin's ftp is problematic for a Windows
+;; oriented XEmacs
+;(setq efs-ftp-program-name "C:/Windows/System32/Ftp")
+
+;; Set shell-file-name and shell-command-switch for Tramp
+;(setq shell-file-name "cmd.exe")
+;(setq shell-command-switch "/e:4096 /c")
+
+;; Set default tramp-default-method to ssh as well as
+;; insert ":" into shell-prompt-pattern
+(setq tramp-default-method "ssh")
+(setq shell-prompt-pattern "^[^#$%>:\n]*[#$%>:] *")
+
+;; Set mail server
+(set-variable 'smtpmail-smtp-server '"defaria.com")
+
+;;default font and face properties.
+(progn
+ (set-face-foreground 'default "black")
+;; (set-face-background 'default "#e4deb4")
+ (set-face-background 'default "white")
+ (set-face-font 'default "Lucida Console:Regular:10"))
+
+;; Startup a certain size
+(set-frame-height (selected-frame) 50)
+(set-frame-width (selected-frame) 90)
+
+;; Set background
+;;(set-face-background-pixmap 'default
+;; (expand-file-name "P:/Documents/pad.jpg")
+;; (get-buffer "*info*"))
+
+;; VC mode
+;;require 'vc
+
+;; Fix problem with Clearcase.el
+(require 'timer)
+
+;; Change comment-column to 0 for perl. comment-column is used for one
+;; of the two types of comment lines that the perl mode supports -
+;; full line comments and inline comments. The comment-column is used
+;; for the inline comments, which I rarely use. Setting it to 0 means
+;; don't try to align things. So I'll just align them myself.
+(defun perl-zero-comment-column ()
+ (setq comment-column 0)) (add-hook 'cperl-mode-hook 'perl-zero-comment-column)
+
+(global-set-key "\C-z" 'undo)
+(mouse-avoidance-mode 'cat-and-mouse)
--- /dev/null
+;;=============================================================================
+;; scroll on mouse wheel
+;;=============================================================================
+;; scroll on wheel of mouses
+(define-key global-map 'button4
+ '(lambda (&rest args)
+ (interactive)
+ (let ((curwin (selected-window)))
+ (select-window (car (mouse-pixel-position)))
+ (scroll-down 5)
+ (select-window curwin)
+ )))
+(define-key global-map [(shift button4)]
+ '(lambda (&rest args)
+ (interactive)
+ (let ((curwin (selected-window)))
+ (select-window (car (mouse-pixel-position)))
+ (scroll-down 1)
+ (select-window curwin)
+ )))
+(define-key global-map [(control button4)]
+ '(lambda (&rest args)
+ (interactive)
+ (let ((curwin (selected-window)))
+ (select-window (car (mouse-pixel-position)))
+ (scroll-down)
+ (select-window curwin)
+ )))
+
+(define-key global-map 'button5
+ '(lambda (&rest args)
+ (interactive)
+ (let ((curwin (selected-window)))
+ (select-window (car (mouse-pixel-position)))
+ (scroll-up 5)
+ (select-window curwin)
+ )))
+(define-key global-map [(shift button5)]
+ '(lambda (&rest args)
+ (interactive)
+ (let ((curwin (selected-window)))
+ (select-window (car (mouse-pixel-position)))
+ (scroll-up 1)
+ (select-window curwin)
+ )))
+(define-key global-map [(control button5)]
+ '(lambda (&rest args)
+ (interactive)
+ (let ((curwin (selected-window)))
+ (select-window (car (mouse-pixel-position)))
+ (scroll-up)
+ (select-window curwin)
+ )))
\ No newline at end of file
--- /dev/null
+;;; perlcritic.el --- minor mode for Perl::Critic integration
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/distributions/Perl-Critic/extras/perlcritic.el $
+;;; $Date: 2009/04/23 15:46:13 $
+;;; $Author: andrew $
+;;; $Revision: 1.1 $
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+;;; Readme
+;;
+;; This is a minor mode for emacs intended to allow you to
+;; automatically incorporate perlcritic into your daily code
+;; writing. When enabled it can optionally prevent you from saving
+;; code that doesn't pass your enabled perlcritic policies.
+;;
+;; Even if you don't enable the automatic code checking you can still
+;; use the automatic checking or the `perlcritic' function.
+
+
+;;; Installation instructions:
+;;
+;; Copy perlcritic.el to your ~/.site-lib directory. If you don't
+;; have a .site-lib directory create it and add the following line
+;; to your .emacs file. This location isn't special, you could use
+;; a different location if you wished.
+;;
+;; (add-to-list 'load-path "/home/your-name/.site-lisp")
+;;
+;; Add the following lines to your .emacs file. This allows Emacs
+;; to load your perlcritic library only when needed.
+;;
+;; (autoload 'perlcritic "perlcritic" "" t)
+;; (autoload 'perlcritic-region "perlcritic" "" t)
+;; (autoload 'perlcritic-mode "perlcritic" "" t)
+;;
+;; Add the following to your .emacs file to get perlcritic-mode to
+;; run automatically for the `cperl-mode' and `perl-mode'.
+;;
+;; (eval-after-load "cperl-mode"
+;; '(add-hook 'cperl-mode-hook 'perlcritic-mode))
+;; (eval-after-load "perl-mode"
+;; '(add-hook 'perl-mode-hook 'perlcritic-mode))
+;;
+;;
+;; If you think you need perlcritic loaded all the time you can
+;; make this unconditional by using the following command instead
+;; of the above autoloading.
+;;
+;; (require 'perlcritic)
+;;
+;; Compile the file for extra performance. This is optional. You
+;; will have to redo this everytime you modify or upgrade your
+;; perlcritic.el file.
+;;
+;; M-x byte-compile-file ~/.site-lib/perlcritic.el
+;;
+;; Additional customization can be found in the Perl::Critic group
+;; in the Tools section in the Programming section of your Emacs'
+;; customization menus.
+
+
+;;; TODO
+;;
+;; Find out how to get perlcritic customization stuff into the
+;; customization menus without having to load perlcritic.el
+;; first.
+;;
+;; This needs an installer. Is there anything I can use in
+;; ExtUtils::MakeMaker, Module::Build, or Module::Install?
+;; Alien::?
+;;
+;; XEmacs compatibility. I use GNU Emacs and don't test in
+;; XEmacs. I'm happy to do what it takes to be compatible but
+;; someone will have to point things out to me.
+;;
+;; Make all documentation strings start with a sentence that fits
+;; on one line. See "Tips for Documentation Strings" in the Emacs
+;; Lisp manual.
+;;
+;; Any FIXME, TODO, or XXX tags below.
+
+
+;;; Change Log:
+;; 0.10
+;; * Synched up regexp alist with Perl::Critic::Utils and accounted for all
+;; past patterns too.
+;; 0.09
+;; * Added documentation for perlcritic-top, perlcritic-include,
+;; perlcritic-exclude, perlcritic-force, perlcritic-verbose.
+;; * Added emacs/vim editor hints to the bottom.
+;; * Corrected indentation.
+;; 0.08
+;; * Fixed perlcritic-compilation-error-regexp-alist for all
+;; severity levels.
+;; * Added documentation strings for functions.
+;; 0.07
+;; * Moved perlcritic-compilation-error-regexp-alist so it is in the
+;; source before it's used. This only seems to matter when
+;; perlcritic.el is compiled to bytecode.
+;; * Added perlcritic-exclude, perlcritic-include
+
+;; 0.06
+;; * Code cleanliness.
+;; * Comment cleanliness.
+;; * Nice error message when perlcritic warns.
+;; * Documented perlcritic-top, perlcritic-verbose.
+;; * Regular expressions for the other standard -verbose levels.
+;; * Reversed Changes list so the most recent is first.
+;; * Standard emacs library declarations.
+;; * Added autoloading metadata.
+;; 0.05
+;; * perlcritic-bin invocation now shown in output.
+;; * Fixed indentation.
+;; * perlcritic-region is now interactive.
+;; 0.04
+;; * Removed a roque file-level (setq perlcritic-top 1)
+;; * Moved cl library to compile-time.
+;; 0.03
+;; * compile.el integration. This makes for hotlink happiness.
+;; * Better sanity when starting the *perlcritic* buffer.
+;; 0.02
+;; * perlcritic-severity-level added.
+;; * Touched up the installation documentation.
+;; * perlcritic-pass-required is now buffer local.
+;; 0.01
+;; * It's new. I copied much of this from perl-lint-mode.
+
+;;; Copyright and license
+;;
+;; 2006 Joshua ben Jore <jjore@cpan.org>
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the same terms as Perl itself
+
+
+
+\f
+;;; Code:
+
+;;; Customization and variables.
+(defgroup perlcritic nil "Perl::Critic"
+ :prefix "perlcritic-"
+ :group 'tools)
+
+(defcustom perlcritic-bin "perlcritic"
+ "The perlcritic program used by `perlcritic'."
+ :type 'string
+ :group 'perlcritic)
+
+(defcustom perlcritic-pass-required nil
+ "When \\[perlcritic-mode] is enabled then this boolean controls
+whether your file can be saved when there are perlcritic warnings.
+
+This variable is automatically buffer-local and may be overridden on a
+per-file basis with File Variables."
+ :type '(radio
+ (const :tag "Require no warnings from perlcritic to save" t)
+ (const :tag "Allow warnings from perlcritic when saving" nil))
+ :group 'perlcritic)
+(make-variable-buffer-local 'perlcritic-pass-required)
+
+(defcustom perlcritic-profile nil
+ "Specify an alternate .perlcriticrc file. This is only used if
+non-nil."
+ :type '(string)
+ :group 'perlcritic)
+(make-variable-buffer-local 'perlcritic-profile)
+
+(defcustom perlcritic-noprofile nil
+ "Disables the use of any .perlcriticrc file."
+ :type '(boolean)
+ :group 'perlcritic)
+(make-variable-buffer-local 'perlcritic-noprofile)
+
+(defcustom perlcritic-severity nil
+ "Directs perlcritic to only report violations of Policies with a
+severity greater than N. Severity values are integers ranging from
+1 (least severe) to 5 (most severe). The default is 5. For a given
+-profile, decreasing the -severity will usually produce more
+violations. Users can redefine the severity for any Policy in their
+.perlcriticrc file.
+
+This variable is automatically buffer-local and may be overridden on a
+per-file basis with File Variables."
+ ;; FIXME: My GNU Emacs doesn't show a radio widget or a menu here.
+ :type '(radio
+ (const :tag "Show only the most severe: 5" 5)
+ (const :tag "4" 4)
+ (const :tag "3" 3)
+ (const :tag "2" 2)
+ (const :tag "Show everything including the least severe: 1" 1))
+ :group 'perlcritic)
+(make-variable-buffer-local 'perlcritic-severity)
+
+(defcustom perlcritic-top nil
+ "Directs \"perlcritic\" to report only the top N Policy violations in
+each file, ranked by their severity. If the -severity option is not
+explicitly given, the -top option implies that the minimum severity
+level is 1. Users can redefine the severity for any Policy in their
+.perlcriticrc file.
+
+This variable is automatically buffer-local and may be overridden on a
+per-file basis with File Variables."
+ :type '(integer)
+ :group 'perlcritic)
+(make-variable-buffer-local 'perlcritic-top)
+
+(defcustom perlcritic-include nil
+ "Directs \"perlcritic\" to apply additional Policies that match the regex \"/PATTERN/imx\".
+Use this option to override your profile and/or the severity settings.
+
+For example:
+
+ layout
+
+This would cause \"perlcritic\" to apply all the \"CodeLayout::*\" policies
+even if they have a severity level that is less than the default level of 5,
+or have been disabled in your .perlcriticrc file. You can specify multiple
+`perlcritic-include' options and you can use it in conjunction with the
+`perlcritic-exclude' option. Note that `perlcritic-exclude' takes precedence
+over `perlcritic-include' when a Policy matches both patterns. You can set
+the default value for this option in your .perlcriticrc file."
+ :type '(string)
+ :group 'perlcritic)
+(make-variable-buffer-local 'perlcritic-include)
+
+(defcustom perlcritic-exclude nil
+ "Directs \"perlcritic\" to not apply any Policy that matches the regex
+\"/PATTERN/imx\". Use this option to temporarily override your profile and/or
+the severity settings at the command-line. For example:
+
+ strict
+
+This would cause \"perlcritic\" to not apply the \"RequireUseStrict\" and
+\"ProhibitNoStrict\" Policies even though they have the highest severity
+level. You can specify multiple `perlcritic-exclude' options and you can use
+it in conjunction with the `perlcritic-include' option. Note that
+`perlcritic-exclude' takes precedence over `perlcritic-include' when a Policy
+matches both patterns. You can set the default value for this option in your
+.perlcriticrc file."
+ :type '(string)
+ :group 'perlcritic)
+(make-variable-buffer-local 'perlcritic-exclude)
+
+
+(defcustom perlcritic-force nil
+ "Directs \"perlcritic\" to ignore the magical \"## no critic\"
+pseudo-pragmas in the source code. You can set the default value for this
+option in your .perlcriticrc file."
+ :type '(boolean)
+ :group 'perlcritic)
+(make-variable-buffer-local 'perlcritic-force)
+
+(defcustom perlcritic-verbose nil
+ "Sets the numeric verbosity level or format for reporting violations. If
+given a number (\"N\"), \"perlcritic\" reports violations using one of the
+predefined formats described below. If the `perlcritic-verbose' option is not
+specified, it defaults to either 4 or 5, depending on whether multiple files
+were given as arguments to \"perlcritic\". You can set the default value for
+this option in your .perlcriticrc file.
+
+Verbosity Format Specification
+----------- -------------------------------------------------------------
+ 1 \"%f:%l:%c:%m\n\",
+ 2 \"%f: (%l:%c) %m\n\",
+ 3 \"%m at %f line %l\n\",
+ 4 \"%m at line %l, column %c. %e. (Severity: %s)\n\",
+ 5 \"%f: %m at line %l, column %c. %e. (Severity: %s)\n\",
+ 6 \"%m at line %l, near ’%r’. (Severity: %s)\n\",
+ 7 \"%f: %m at line %l near ’%r’. (Severity: %s)\n\",
+ 8 \"[%p] %m at line %l, column %c. (Severity: %s)\n\",
+ 9 \"[%p] %m at line %l, near ’%r’. (Severity: %s)\n\",
+10 \"%m at line %l, column %c.\n %p (Severity: %s)\n%d\n\",
+11 \"%m at line %l, near ’%r’.\n %p (Severity: %s)\n%d\n\"
+
+Formats are a combination of literal and escape characters similar to the way
+\"sprintf\" works. See String::Format for a full explanation of the
+formatting capabilities. Valid escape characters are:
+
+Escape Meaning
+------- ----------------------------------------------------------------
+%c Column number where the violation occurred
+%d Full diagnostic discussion of the violation
+%e Explanation of violation or page numbers in PBP
+%F Just the name of the file where the violation occurred.
+%f Path to the file where the violation occurred.
+%l Line number where the violation occurred
+%m Brief description of the violation
+%P Full name of the Policy module that created the violation
+%p Name of the Policy without the Perl::Critic::Policy:: prefix
+%r The string of source code that caused the violation
+%s The severity level of the violation
+
+The purpose of these formats is to provide some compatibility with text
+editors that have an interface for parsing certain kinds of input.
+
+
+This variable is automatically buffer-local and may be overridden on a
+per-file basis with File Variables."
+ :type '(integer)
+ :group 'perlcritic)
+(make-variable-buffer-local 'perlcritic-verbose)
+
+;; TODO: Enable strings in perlcritic-verbose.
+;; (defcustom perlcritic-verbose-regexp nil
+;; "An optional regexp to match the warning output.
+;;
+;; This is used when `perlcritic-verbose' has a regexp instead of one of
+;; the standard verbose levels.")
+;; (make-local-variable 'perlcritic-verbose-regexp)
+
+
+;; compile.el requires that something be the "filename." I've tagged
+;; the severity with that. It happens to make it get highlighted in
+;; red. The following advice on COMPILATION-FIND-FILE makes sure that
+;; the "filename" is getting ignored when perlcritic is using it.
+
+;; These patterns are defined in Perl::Critic::Utils
+
+(defvar perlcritic-compilation-error-regexp-alist
+ '(;; Verbose level 1
+ ;; "%f:%l:%c:%m\n"
+ ("^\\([^\n]+\\):\\([0-9]+\\):\\([0-9]+\\)" 1 2 3)
+
+ ;; Verbose level 2
+ ;; "%f: (%l:%c) %m\n"
+ ("^\\([^\n]+\\): (\\([0-9]+\\):\\([0-9]+\\))" 1 2 3)
+
+ ;; Verbose level 3
+ ;; "%m at %f line %l\n"
+ ("^[^\n]+ at \\([^\n]+\\) line \\([0-9]+\\)" 1 2)
+ ;; "%m at line %l, column %c. %e. (Severity: %s)\n"
+ ("^[^\n]+ at line\\( \\)\\([0-9]+\\), column \\([0-9]+\\)." 1 2 3)
+
+ ;; Verbose level 4
+ ;; "%m at line %l, column %c. %e. (Severity: %s)\n"
+ ("^[^\n]+ at line\\( \\)\\([0-9]+\\), column \\([0-9]+\\)." 1 2 3)
+ ;; "%f: %m at line %l, column %c. %e. (Severity: %s)\n"
+ ("^\\([^\n]+\\): [^\n]+ at line \\([0-9]+\\), column \\([0-9]+\\)" 1 2 3)
+
+ ;; Verbose level 5
+ ;; "%m at line %l, near '%r'. (Severity: %s)\n"
+ ("^[^\n]+ at line\\( \\)\\([0-9]+\\)," 1 2)
+ ;; "%f: %m at line %l, column %c. %e. (Severity: %s)\n"
+ ("^\\([^\n]+\\): [^\n]+ at line \\([0-9]+\\), column \\([0-9]+\\)" 1 2 3)
+
+ ;; Verbose level 6
+ ;; "%m at line %l, near '%r'. (Severity: %s)\\n"
+ ("^[^\n]+ at line\\( \\)\\([0-9]+\\)" 1 2)
+ ;; "%f: %m at line %l near '%r'. (Severity: %s)\n"
+ ("^\\([^\n]+\\): [^\n]+ at line \\([0-9]+\\)" 1 2)
+
+ ;; Verbose level 7
+ ;; "%f: %m at line %l near '%r'. (Severity: %s)\n"
+ ("^\\([^\n]+\\): [^\n]+ at line \\([0-9]+\\)" 1 2)
+ ;; "[%p] %m at line %l, column %c. (Severity: %s)\n"
+ ("^\\[[^\n]+\\] [^\n]+ at line\\( \\)\\([0-9]+\\), column \\([0-9]+\\)" 1 2 3)
+
+ ;; Verbose level 8
+ ;; "[%p] %m at line %l, column %c. (Severity: %s)\n"
+ ("^\\[[^\n]+\\] [^\n]+ at line\\( \\)\\([0-9]+\\), column \\([0-9]+\\)" 1 2 3)
+ ;; "[%p] %m at line %l, near '%r'. (Severity: %s)\n"
+ ("^\\[[^\n]+\\] [^\n]+ at line\\( \\)\\([0-9]+\\)" 1 2)
+
+ ;; Verbose level 9
+ ;; "%m at line %l, column %c.\n %p (Severity: %s)\n%d\n"
+ ("^[^\n]+ at line\\( \\)\\([0-9]+\\), column \\([0-9]+\\)" 1 2 3)
+ ;; "[%p] %m at line %l, near '%r'. (Severity: %s)\n"
+ ("^\\[[^\n]+\\] [^\n]+ at line\\( \\)\\([0-9]+\\)" 1 2)
+
+ ;; Verbose level 10
+ ;; "%m at line %l, near '%r'.\n %p (Severity: %s)\n%d\n"
+ ("^[^\n]+ at line\\( \\)\\([0-9]+\\)" 1 2)
+ ;; "%m at line %l, column %c.\n %p (Severity: %s)\n%d\n"
+ ("^[^\n]+ at line\\( \\)\\([0-9]+\\), column \\([0-9]+\\)" 1 2 3)
+
+ ;; Verbose level 11
+ ;; "%m at line %l, near '%r'.\n %p (Severity: %s)\n%d\n"
+ ("^[^\n]+ at line\\( \\)\\([0-9]+\\)" 1 2)
+ )
+ "Alist that specified how to match errors in perlcritic output.")
+
+
+\f
+;; The Emacs Lisp manual says to do this with the cl library.
+(eval-when-compile (require 'cl))
+
+;;;###autoload
+(defun perlcritic ()
+ "\\[perlcritic]] returns a either nil or t depending on whether the
+current buffer passes perlcritic's check. If there are any warnings
+those are displayed in a separate buffer."
+ (interactive)
+ (print "in perlcritic")
+ (save-restriction
+ (widen)
+ (perlcritic-region (point-min) (point-max))))
+
+;;;###autoload
+(defun perlcritic-region (start end)
+ "\\[perlcritic-region] returns a either nil or t depending on
+whether the region passes perlcritic's check. If there are any
+warnings those are displayed in a separate buffer."
+
+ (interactive "r")
+
+ (message "In perlcritic-region")
+
+ ;; Kill the perlcritic buffer so I can make a new one.
+ (if (get-buffer "*perlcritic*")
+ (kill-buffer "*perlcritic*"))
+
+ ;; In the following lines I'll be switching between buffers
+ ;; freely. This upper save-excursion will keep things sane.
+ (save-excursion
+ (let ((src-buf (current-buffer))
+ (err-buf (get-buffer-create "*perlcritic*")))
+
+ (set-buffer src-buf)
+ (let ((perlcritic-args (loop for p in (list
+ ;; Add new bin/perlcritic
+ ;; parameters here!
+ (perlcritic--param-profile)
+ (perlcritic--param-noprofile)
+ (perlcritic--param-severity)
+ (perlcritic--param-top)
+ (perlcritic--param-include)
+ (perlcritic--param-exclude)
+ (perlcritic--param-force)
+ (perlcritic--param-verbose))
+ unless (null p)
+ append p)))
+ ;
+ (message "Perl critic...running")
+ ;; Seriously. Is this the nicest way to call
+ ;; CALL-PROCESS-REGION with variadic arguments? This blows!
+ ;; (apply FUNCTION (append STATIC-PART DYNAMIC-PART))
+ (message "perlcritic1")
+ (message (concat "Starting " perlcritic-bin))
+ (let ((rc (apply 'call-process-region
+ (nconc (list start end
+ perlcritic-bin nil
+ (list err-buf t)
+ nil)
+ perlcritic-args))))
+(message "perlcritic2")
+
+ ;; Figure out whether we're ok or not. perlcritic has to
+ ;; return zero and the output buffer has to be empty except
+ ;; for that "... source OK" line. Different versions of the
+ ;; perlcritic script will print different things when
+ ;; they're ok. I expect to see things like "some-file source
+ ;; OK", "SCALAR=(0x123457) source OK", "STDIN source OK",
+ ;; and "source OK".
+ (let ((perlcritic-ok (and (numberp rc)
+ (zerop rc)
+ (progn
+ (set-buffer err-buf)
+ (goto-char (point-min))
+ (delete-matching-lines "source OK$")
+ (zerop (buffer-size))))))
+ ;; Either clean up or finish setting up my output.
+ (if perlcritic-ok
+ ;; Ok!
+ (progn
+ (kill-buffer err-buf)
+ (message "Perl critic...ok"))
+
+
+ ;; Not ok!
+ (message "Perl critic...not ok")
+
+ ;; Set up the output buffer now I know it'll be used. I
+ ;; scooped the guts out of compile-internal. It is
+ ;; CRITICAL that the errors start at least two lines
+ ;; from the top. compile.el normally assumes the first
+ ;; line is an informational `cd somedirectory' command
+ ;; and the second line shows the program's invocation.
+ ;;
+ ;; Since I have the space available I've put the
+ ;; program's invocation here. Maybe it'd make sense to
+ ;; put the buffer's directory here somewhere too.
+ (set-buffer err-buf)
+ (goto-char (point-min))
+ (insert (reduce (lambda (a b) (concat a " " b))
+ (nconc (list perlcritic-bin)
+ perlcritic-args))
+ "\n"
+ ;; TODO: instead of a blank line, print the
+ ;; buffer's directory+file.
+ "\n")
+ (goto-char (point-min))
+ ;; TODO: get `recompile' to work.
+
+ ;; just an fyi. compilation-mode will delete my local
+ ;; variables so be sure to call it *first*.
+ (compilation-mode "perlcritic")
+ (set (make-local-variable 'perlcritic-buffer) src-buf)
+ (set (make-local-variable 'compilation-error-regexp-alist)
+ perlcritic-compilation-error-regexp-alist)
+ (ad-activate #'compilation-find-file)
+ ; (ad-deactivate #'compilation-find-file)
+ (display-buffer err-buf))
+
+ ;; Return our success or failure.
+ perlcritic-ok))))))
+
+
+
+\f
+;;; Parameters for use by perlcritic-region.
+(defun perlcritic--param-profile ()
+ "A private method that supplies the -profile FILENAME parameter for
+\\[perlcritic-region]"
+ (if perlcritic-profile (list "-profile" perlcritic-profile)))
+
+(defun perlcritic--param-noprofile ()
+ "A private method that supplies the -noprofile parameter for
+\\[perlcritic-region]"
+ (if perlcritic-noprofile (list "-noprofile")))
+
+(defun perlcritic--param-force ()
+ "A private method that supplies the -force parameter for
+\\[perlcritic-region]"
+ (if perlcritic-force (list "-force")))
+
+(defun perlcritic--param-severity ()
+ "A private method that supplies the -severity NUMBER parameter for
+\\[perlcritic-region]"
+ (cond ((stringp perlcritic-severity)
+ (list "-severity" perlcritic-severity))
+ ((numberp perlcritic-severity)
+ (list "-severity" (number-to-string perlcritic-severity)))
+ (t nil)))
+
+(defun perlcritic--param-top ()
+ "A private method that supplies the -top NUMBER parameter for
+\\[perlcritic-region]"
+ (cond ((stringp perlcritic-top)
+ (list "-top" perlcritic-top))
+ ((numberp perlcritic-top)
+ (list "-top" (number-to-string perlcritic-top)))
+ (t nil)))
+
+(defun perlcritic--param-include ()
+ "A private method that supplies the -include REGEXP parameter for
+\\[perlcritic-region]"
+ (if perlcritic-include
+ (list "-include" perlcritic-include)
+ nil))
+
+(defun perlcritic--param-exclude ()
+ "A private method that supplies the -exclude REGEXP parameter for
+\\[perlcritic-region]"
+ (if perlcritic-exclude
+ (list "-exclude" perlcritic-exclude)
+ nil))
+
+(defun perlcritic--param-verbose ()
+ "A private method that supplies the -verbose NUMBER parameter for
+\\[perlcritic-region]"
+ (cond ((stringp perlcritic-verbose)
+ (list "-verbose" perlcritic-verbose))
+ ((numberp perlcritic-verbose)
+ (list "-verbose" (number-to-string perlcritic-verbose)))
+ (t nil)))
+
+
+;; Interactive functions for use by the user to modify parameters on
+;; an adhoc basis. I'm sure there's room for significant niceness
+;; here. Suggest something. Please.
+(defun perlcritic-profile (profile)
+ "Sets perlcritic's -profile FILENAME parameter."
+ (interactive "sperlcritic -profile: ")
+ (setq perlcritic-profile (if (string= profile "") nil profile)))
+
+(defun perlcritic-noprofile (noprofile)
+ "Toggles perlcritic's -noprofile parameter."
+ (interactive (list (yes-or-no-p "Enable perlcritic -noprofile? ")))
+ (setq perlcritic-noprofile noprofile))
+
+(defun perlcritic-force (force)
+ "Toggles perlcritic's -force parameter."
+ (interactive (list (yes-or-no-p "Enable perlcritic -force? ")))
+ (setq perlcritic-force force))
+
+(defun perlcritic-severity (severity)
+ "Sets perlcritic's -severity NUMBER parameter."
+ (interactive "nperlcritic -severity: ")
+ (setq perlcritic-severity severity))
+
+(defun perlcritic-top (top)
+ "Sets perlcritic's -top NUMBER parameter."
+ (interactive "nperlcritic -top: ")
+ (setq perlcritic-top top))
+
+(defun perlcritic-include (include)
+ "Sets perlcritic's -include REGEXP parameter."
+ (interactive "sperlcritic -include: ")
+ (setq perlcritic-include include))
+
+(defun perlcritic-exclude (exclude)
+ "Sets perlcritic's -exclude REGEXP parameter."
+ (interactive "sperlcritic -exclude: ")
+ (setq perlcritic-exclude exclude))
+
+(defun perlcritic-verbose (verbose)
+ "Sets perlcritic's -verbose NUMBER parameter."
+ (interactive "nperlcritic -verbose: ")
+ (setq perlcritic-verbose verbose))
+
+
+
+
+\f
+;; Hooks compile.el's compilation-find-file to enable our file-less
+;; operation. We feed `perlcritic-bin' from STDIN, not from a file.
+(defadvice compilation-find-file (around perlcritic-find-file)
+ "Lets perlcritic lookup into the buffer we just came from and don't
+require that the perl document exist in a file anywhere."
+ (let ((debug-buffer (marker-buffer marker)))
+ (if (local-variable-p 'perlcritic-buffer debug-buffer)
+ (setq ad-return-value perlcritic-buffer)
+ ad-do-it)))
+
+
+
+
+
+;; All the scaffolding of having a minor mode.
+(defvar perlcritic-mode nil
+ "Toggle `perlcritic-mode'")
+(make-variable-buffer-local 'perlcritic-mode)
+
+(defun perlcritic-write-hook ()
+ "Check perlcritic during `write-file-hooks' for `perlcritic-mode'"
+ (if perlcritic-mode
+ (save-excursion
+ (widen)
+ (mark-whole-buffer)
+ (let ((perlcritic-ok (perlcritic)))
+ (if perlcritic-pass-required
+ ;; Impede saving if we're not ok.
+ (not perlcritic-ok)
+ ;; Don't impede saving. We might not be ok but that
+ ;; doesn't matter now.
+ nil)))
+ ;; Don't impede saving. We're not in perlcritic-mode.
+ nil))
+
+;;;###autoload
+(defun perlcritic-mode (&optional arg)
+ "Perl::Critic checking minor mode."
+ (interactive "P")
+
+ ;; Enable/disable perlcritic-mode
+ (setq perlcritic-mode (if (null arg)
+ ;; Nothing! Just toggle it.
+ (not perlcritic-mode)
+ ;; Set it.
+ (> (prefix-numeric-value arg) 0)))
+
+ (make-local-hook 'write-file-hooks)
+ (if perlcritic-mode
+ (add-hook 'write-file-hooks 'perlcritic-write-hook)
+ (remove-hook 'write-file-hooks 'perlcritic-write-hook)))
+
+;; Make a nice name for perl critic mode. This string will appear at
+;; the bottom of the screen.
+(if (not (assq 'perlcritic-mode minor-mode-alist))
+ (setq minor-mode-alist
+ (cons '(perlcritic-mode " Critic")
+ minor-mode-alist)))
+
+(provide 'perlcritic)
+
+;; Local Variables:
+;; mode: emacs-lisp
+;; tab-width: 8
+;; fill-column: 78
+;; indent-tabs-mode: nil
+;; End:
+;; ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
+
+;;; perlcritic.el ends here
--- /dev/null
+;;; perltidy-mode.el --- Minor mode to automatically perltidy.
+
+;;; Perltidy is a program that is available on CPAN.
+
+;;; Copyright 2006 Joshua ben Jore
+
+;;; Author: Joshua ben Jore <jjore@cpan.org>
+;;; Version: 0.02
+;;; CVS Version: $Id: perltidy.el,v 1.1 2009/04/23 15:46:13 andrew Exp $
+;;; Keywords: perl perltidy
+;;; X-URL: http://search.cpan.org/~jjore/perltidy-mode/
+
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the same terms as Perl itself.
+
+;;; To install this first generate your perltidy-mode.el file by running
+;;; perltidy-mode.PL with your copy of perl. Copy the generated perltidy-mode.el to
+;;; your ~/.site-lisp/ directory or a different preferred location.
+;;;
+;;; Add the following lines to your .emacs file to inform emacs of the directory
+;;; and of the two main functions provided by this library.
+;;;
+;;; (add-to-list 'load-path "~/.site-lisp/")
+;;; (autoload 'perltidy "perltidy-mode" nil t)
+;;; (autoload 'perltidy-mode "perltidy-mode" nil t)
+;;;
+;;; Add the following snippet to enable full-auto mode.
+;;;
+;;; (eval-after-load "cperl-mode"
+;;; '(add-hook 'cperl-mode-hook 'perltidy-mode))
+;;;
+;;; Add the following snippet to set the C-ct key sequence to trigger
+;;; perltidy.
+;;;
+;;; ; Run perltidy when the C-ct key sequence is used.
+;;; (global-set-key "\C-ct" 'perltidy)
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; Perltidy
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defvar perltidy-bin "perltidy"
+ "The command to run perltidy.")
+
+(defmacro mark-active ()
+ "Xemacs/emacs compatibility macro. It returns either nil or non-nil
+and there are no guarantees about what constitutes \"non-nil\"."
+ (if (boundp 'mark-active)
+ `mark-active
+ `(mark)))
+
+(defun perltidy (start-in end-in)
+ "Run perltidy on the current region or buffer."
+ (interactive "r")
+
+ (let ((start (or start-in (point-min)))
+ (end (or end-in (point-max)))
+ (original-line (point->line (point)))
+ (error-buffer (get-buffer-create "*perltidy-errors*")))
+
+ ; Clear the error buffer if needed.
+ (or (zerop (buffer-size error-buffer))
+ (save-excursion (set-buffer error-buffer)
+ (erase-buffer)))
+
+ ; Inexplicably, save-excursion doesn't work to restore the
+ ; point. I'm using it to restore the mark and point and manually
+ ; navigating to the proper new-line.
+ (let ((result
+ (save-excursion
+ (if (zerop (shell-command-on-region start end perltidy-bin error-buffer))
+ ; Success! Clean up.
+ (progn
+ (kill-buffer error-buffer)
+ t)
+
+ ; Oops! Show our error and give back the text that
+ ; shell-command-on-region stole.
+ (progn (undo)
+ (display-buffer error-buffer)
+ nil)))))
+
+ ; This goto-line is outside the save-excursion becuase it'd get
+ ; removed otherwise. I hate this bug. It makes things so ugly.
+ (goto-line original-line)
+ result)))
+
+
+(defun point->line (point)
+ "Get the line number that POINT is on."
+ ; I'm not bothering to use save-excursion because I think I'm
+ ; calling this function from inside other things that are likely to
+ ; use that and all I really need to do is restore my current
+ ; point. So that's what I'm doing manually.
+ (let ((line 1)
+ (original-point (point)))
+ (goto-char (point-min))
+ (while (< (point) point)
+ (incf line)
+ (forward-line))
+ (goto-char original-point)
+ line))
+
+
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; Automatic perltidy
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defvar perltidy-mode nil
+ "Automatically `perltidy' when saving.")
+(make-variable-buffer-local 'perltidy-mode)
+
+(defun perltidy-write-hook ()
+ "Perltidys a buffer during `write-file-hooks' for
+`perltidy-mode'. If perltidy returns nil then the buffer isn't saved."
+ (if perltidy-mode
+ (save-restriction
+ (widen)
+ ; Impede the save if perltidy is false.
+ (not (perltidy (point-min) (point-max))))
+ ; Don't impede the save.
+ nil))
+
+(defun perltidy-mode (&optional arg)
+ "Perltidy minor mode."
+ (interactive "P")
+
+ ; Cargo-culted from the Extending Emacs book.
+ (setq perltidy-mode (if (null arg)
+ ; Toggle it on and off.
+ (not perltidy-mode)
+ ; Enable if >0.
+ (> (prefix-numeric-value arg) 0)))
+
+ (make-local-hook 'write-file-hooks)
+ (funcall (if perltidy-mode #'add-hook #'remove-hook)
+ 'write-file-hooks 'perltidy-write-hook))
+
+; Add this to the list of minor modes.
+(if (not (assq 'perltidy-mode minor-mode-alist))
+ (setq minor-mode-alist
+ (cons '(perltidy-mode " Perltidy")
+ minor-mode-alist)))
+
+(provide 'perltidy-mode)
+
+;;; perltidy-mode.el ends here
--- /dev/null
+;; visual-basic-mode.el --- A mode for editing Visual Basic programs.
+;; Modified version of Fred White's visual-basic-mode.el
+
+;; Copyright (C) 1996 Fred White <fwhite@alum.mit.edu>
+;; Copyright (C) 1998 Free Software Foundation, Inc.
+;; (additions by Dave Love)
+
+;; Author: Fred White <fwhite@alum.mit.edu>
+;; Adapted-by: Dave Love <d.love@dl.ac.uk>
+;; : Kevin Whitefoot <kevin.whitefoot@nopow.abb.no>
+;; Version: 1.3 (May 1, 1996)
+;; Keywords: languages, basic, Evil
+
+
+;; (Old) LCD Archive Entry:
+;; basic-mode|Fred White|fwhite@alum.mit.edu|
+;; A mode for editing Visual Basic programs.|
+;; 18-Apr-96|1.0|~/modes/basic-mode.el.Z|
+
+;; This file is NOT part of GNU Emacs but the same permissions apply.
+;;
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published
+;; by the Free Software Foundation; either version 2, or (at your
+;; option) any later version.
+;;
+;; GNU Emacs is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2 of the
+;; License, or (at your option) any later version.
+
+;;; Commentary:
+
+;; Purpose of this package:
+;; This is a mode for editing programs written in The World's Most
+;; Successful Programming Language. It features automatic
+;; indentation, font locking, keyword capitalization, and some minor
+;; convenience functions.
+
+;; Installation instructions
+;; Put basic-mode.el somewhere in your path, compile it, and add the
+;; following to your init file:
+
+;; (autoload 'visual-basic-mode "visual-basic-mode" "Visual Basic mode." t)
+;; (setq auto-mode-alist (append '(("\\.\\(frm\\|bas\\|cls\\)$" .
+;; visual-basic-mode)) auto-mode-alist))
+
+;; Of course, under Windows 3.1, you'll have to name this file
+;; something shorter than visual-basic-mode.el
+
+;; Revisions:
+;; 1.0 18-Apr-96 Initial version
+;; 1.1 Accomodate emacs 19.29+ font-lock-defaults
+;; Simon Marshall <Simon.Marshall@esrin.esa.it>
+; 1.2 Rename to visual-basic-mode
+;; 1.3 Fix some indentation bugs.
+;; 1.3+ Changes by Dave Love: [No attempt at compatibility with
+;; anything other than Emacs 20, sorry, but little attempt to
+;; sanitize for Emacs 20 specifically.]
+;; Change `_' syntax only for font-lock and imenu, not generally;
+;; provide levels of font-locking in the current fashion;
+;; font-lock case-insensitively; use regexp-opt with the font-lok
+;; keywords; imenu support; `visual-basic-split-line', bound to
+;; C-M-j; account for single-statement `if' in indentation; add
+;; keyword "Global"; use local-write-file-hooks, not
+;; write-file-hooks.
+;; 1.4 September 1998
+;; 1.4 KJW Add begin..end, add extra keywords
+;; Add customisation for single line if. Disallow by default.
+;; Fix if regexp to require whitespace after if and require then.
+;; Add more VB keywords. Make begin..end work as if..endif so
+;; that forms are formatted correctly.
+;; 1.4.1 KJW Merged Dave Love and KJW versions.
+;; Added keywords suggested by Mickey Ferguson
+;; <MFerguson@peinc.com>
+;; Fixed imenu variable to find private variables and enums
+
+;; Changed syntax class of =, <, > to punctuation to allow dynamic
+;; abbreviations to pick up only the word at point rather than the
+;; whole expression.
+
+;; Fixed bug introduced by KJW adding suport for begin...end in
+;; forms whereby a single end outdented.
+
+;; Partially fixed failure to recognise if statements with
+;; continuations (still fails on 'single line' if with
+;; continuation, ugh).
+
+;;
+;; Notes:
+;; Dave Love
+;; BTW, here's a script for making tags tables that I (Dave Love) have
+;; used with reasonable success. It assumes a hacked version of etags
+;; with support for case-folded regexps. I think this is now in the
+;; development version at <URL:ftp://fly.cnuce.cnr.it/pub/> and should
+;; make it into Emacs after 20.4.
+
+;; #! /bin/sh
+
+;; # etags-vb: (so-called) Visual (so-called) Basic TAGS generation.
+;; # Dave Love <d.love@dl.ac.uk>. Public domain.
+;; # 1997-11-21
+
+;; if [ $# -lt 1 ]; then
+;; echo "Usage: `basename $0` [etags options] VBfile ... [etags options] " 1>&2
+;; exit 1
+;; fi
+
+;; if [ $1 = "--help" ] || [ $1 = "-h" ]; then
+;; echo "Usage: `basename $0` [etags options] VBfile ... [etags options]
+
+;; "
+;; etags --help
+;; fi
+
+;; exec etags --lang=none -c '/\(global\|public\)[ \t]+\(\(const\|type\)[ \t]+\)*\([a-z_0-9]+\)/\4/' \
+;; -c '/public[ \t]+\(sub\|function\)[ \t]+\([a-z_0-9]+\)/\2/' \
+;; "$@"
+
+;; End Notes Dave Love
+
+
+;; Known bugs:
+;; Doesn't know about ":" separated stmts
+;; Doesn't recognize single line if statements if these are broken by
+;; line continuation characters
+
+
+;; todo:
+;; fwd/back-compound-statement
+;; completion over OCX methods and properties.
+;; IDE integration
+;; Change behaviour of ESC-q to recognise words used as paragraph
+;; titles and prevent them being dragged into the previous
+;; paragraph.
+;; etc.
+
+
+;;; Code:
+
+(defvar visual-basic-xemacs-p (string-match "XEmacs\\|Lucid" (emacs-version)))
+(defvar visual-basic-winemacs-p (string-match "Win-Emacs" (emacs-version)))
+(defvar visual-basic-win32-p (eq window-system 'win32))
+
+;; Variables you may want to customize.
+(defvar visual-basic-mode-indent 4 "*Default indentation per nesting level.")
+(defvar visual-basic-fontify-p t "*Whether to fontify Basic buffers.")
+(defvar visual-basic-capitalize-keywords-p t "*Whether to capitalize BASIC keywords.")
+(defvar visual-basic-wild-files "*.frm *.bas *.cls" "*Wildcard pattern for BASIC source files.")
+(defvar visual-basic-ide-pathname nil "*The full pathname of your VB exe file, if any.")
+;; KJW Provide for my preference in if statements
+(defvar visual-basic-allow-single-line-if nil "*Whether to allow single line if")
+
+(defvar visual-basic-defn-templates
+ (list "Public Sub ()\nEnd Sub\n\n"
+ "Public Function () As Variant\nEnd Function\n\n"
+ "Public Property Get ()\nEnd Property\n\n")
+ "*List of function templates though which visual-basic-new-sub cycles.")
+
+(defvar visual-basic-imenu-generic-expression
+ '((nil "^\\s-*\\(public\\|private\\)*\\s-+\\(declare\\s-+\\)*\\(sub\\|function\\)\\s-+\\(\\sw+\\>\\)"
+ 4)
+ ("Constants"
+ "^\\s-*\\(private\\|public\\|global\\)*\\s-*\\(const\\s-+\\)\\(\\sw+\\>\\s-*=\\s-*.+\\)$\\|'"
+ 3)
+ ("Variables"
+ "^\\(private\\|public\\|global\\|dim\\)+\\s-+\\(\\sw+\\>\\s-+as\\s-+\\sw+\\>\\)"
+ 2)
+ ("Types" "^\\(public\\s-+\\)*type\\s-+\\(\\sw+\\)" 2)))
+
+
+
+(defvar visual-basic-mode-syntax-table nil)
+(if visual-basic-mode-syntax-table
+ ()
+ (setq visual-basic-mode-syntax-table (make-syntax-table))
+ (modify-syntax-entry ?\' "\<" visual-basic-mode-syntax-table) ; Comment starter
+ (modify-syntax-entry ?\n ">" visual-basic-mode-syntax-table)
+ (modify-syntax-entry ?\\ "w" visual-basic-mode-syntax-table) ; backslash is not an escape.
+ (modify-syntax-entry ?\= "." visual-basic-mode-syntax-table)
+ (modify-syntax-entry ?\< "." visual-basic-mode-syntax-table)
+ (modify-syntax-entry ?\> "." visual-basic-mode-syntax-table)) ; Make =, etc., punctuation so that dynamic abbreviations work properly
+
+(defvar visual-basic-mode-map nil)
+(if visual-basic-mode-map
+ ()
+ (setq visual-basic-mode-map (make-sparse-keymap))
+ (define-key visual-basic-mode-map "\t" 'visual-basic-indent-line)
+ (define-key visual-basic-mode-map "\r" 'visual-basic-newline-and-indent)
+ (define-key visual-basic-mode-map "\M-\C-a" 'visual-basic-beginning-of-defun)
+ (define-key visual-basic-mode-map "\M-\C-e" 'visual-basic-end-of-defun)
+ (define-key visual-basic-mode-map "\M-\C-h" 'visual-basic-mark-defun)
+ (define-key visual-basic-mode-map "\M-\C-\\" 'visual-basic-indent-region)
+ (define-key visual-basic-mode-map "\M-q" 'visual-basic-fill-or-indent)
+ (define-key visual-basic-mode-map "\M-\C-j" 'visual-basic-split-line)
+ (cond (visual-basic-winemacs-p
+ (define-key visual-basic-mode-map '(control C) 'visual-basic-start-ide))
+ (visual-basic-win32-p
+ (define-key visual-basic-mode-map (read "[?\\S-\\C-c]") 'visual-basic-start-ide)))
+ (if visual-basic-xemacs-p
+ (progn
+ (define-key visual-basic-mode-map "\M-G" 'visual-basic-grep)
+ (define-key visual-basic-mode-map '(meta backspace) 'backward-kill-word)
+ (define-key visual-basic-mode-map '(control meta /) 'visual-basic-new-sub))))
+
+
+;; These abbrevs are valid only in a code context.
+(defvar visual-basic-mode-abbrev-table nil)
+
+(defvar visual-basic-mode-hook ())
+
+
+;; Is there a way to case-fold all regexp matches?
+;; Change KJW Add enum, , change matching from 0 or more to zero or one for public etc.
+(eval-and-compile
+ (defconst visual-basic-defun-start-regexp
+ (concat
+ "^[ \t]*\\([Pp]ublic \\|[Pp]rivate \\|[Ss]tatic\\|[Ff]riend \\)?"
+ "\\([Ss]ub\\|[Ff]unction\\|[Pp]roperty +[GgSsLl]et\\|[Tt]ype\\|[Ee]num\\)"
+ "[ \t]+\\(\\w+\\)[ \t]*(?")))
+
+(defconst visual-basic-defun-end-regexp
+ "^[ \t]*[Ee]nd \\([Ss]ub\\|[Ff]unction\\|[Pp]roperty\\|[Tt]ype\\|[Ee]num\\)")
+
+
+;; Includes the compile-time #if variation.
+;; KJW fixed if to require a whitespace so as to avoid matching, for
+;; instance, iFileName and to require then.
+
+;; Two versions; one recognizes single line if just as though it were
+;; a multi-line and the other does not. Modified again to remove the
+;; requirement for then so as to allow it to match if statements that
+;; have continuations.
+;;(defconst visual-basic-if-regexp
+;; "^[ \t]*#?[Ii]f[ \t]+.*[ \t]+[Tt]hen[ \t]*.*\\('\\|$\\)")
+(defconst visual-basic-if-regexp
+ "^[ \t]*#?[Ii]f[ \t]+.*[ \t_]+")
+
+(defconst visual-basic-ifthen-regexp "^[ \t]*#?[Ii]f.+\\<[Tt]hen\\>\\s-\\S-+")
+
+(defconst visual-basic-else-regexp "^[ \t]*#?[Ee]lse\\([Ii]f\\)?")
+(defconst visual-basic-endif-regexp "[ \t]*#?[Ee]nd[ \t]*[Ii]f")
+
+(defconst visual-basic-continuation-regexp "^.*\\_[ \t]*$")
+(eval-and-compile
+ (defconst visual-basic-label-regexp "^[ \t]*[a-zA-Z0-9_]+:$"))
+
+(defconst visual-basic-select-regexp "^[ \t]*[Ss]elect[ \t]+[Cc]ase")
+(defconst visual-basic-case-regexp "^[ \t]*[Cc]ase")
+(defconst visual-basic-select-end-regexp "^[ \t]*[Ee]nd[ \t]+[Ss]elect")
+
+
+(defconst visual-basic-for-regexp "^[ \t]*[Ff]or\\b")
+(defconst visual-basic-next-regexp "^[ \t]*[Nn]ext\\b")
+
+(defconst visual-basic-do-regexp "^[ \t]*[Dd]o\\b")
+(defconst visual-basic-loop-regexp "^[ \t]*[Ll]oop\\b")
+
+(defconst visual-basic-while-regexp "^[ \t]*[Ww]hile\\b")
+(defconst visual-basic-wend-regexp "^[ \t]*[Ww]end\\b")
+
+;; Added KJW Begin..end for forms
+(defconst visual-basic-begin-regexp "^[ \t]*[Bb]egin)?")
+;; This has created a bug. End on its own in code should not outdent.
+;; How can we fix this? They are used in separate Lisp expressions so
+;; add another one.
+(defconst visual-basic-end-begin-regexp "^[ \t]*[Ee]nd")
+
+(defconst visual-basic-with-regexp "^[ \t]*[Ww]ith\\b")
+(defconst visual-basic-end-with-regexp "^[ \t]*[Ee]nd[ \t]+[Ww]ith\\b")
+
+(defconst visual-basic-blank-regexp "^[ \t]*$")
+(defconst visual-basic-comment-regexp "^[ \t]*\\s<.*$")
+
+
+;; This is some approximation of the set of reserved words in Visual Basic.
+(eval-and-compile
+ (defvar visual-basic-all-keywords
+ '("Add" "Aggregate" "And" "App" "AppActivate" "Application" "Array" "As"
+ "Asc" "AscB" "Atn" "Attribute"
+ "Beep" "Begin" "BeginTrans" "Boolean" "ByVal" "ByRef"
+ "CBool" "CByte" "CCur"
+ "CDate" "CDbl" "CInt" "CLng" "CSng" "CStr" "CVErr" "CVar" "Call"
+ "Case" "ChDir" "ChDrive" "Character" "Choose" "Chr" "ChrB"
+ "ClassModule" "Clipboard" "Close" "Collection" "Column" "Columns"
+ "Command" "CommitTrans" "CompactDatabase" "Component" "Components"
+ "Const" "Container" "Containers" "Cos" "CreateDatabase" "CreateObject"
+ "CurDir" "Currency"
+ "DBEngine" "DDB" "Data" "Database" "Databases"
+ "Date" "DateAdd" "DateDiff" "DatePart" "DateSerial" "DateValue" "Day"
+ "Debug" "Declare" "Deftype" "DeleteSetting" "Dim" "Dir" "Do"
+ "DoEvents" "Domain"
+ "Double" "Dynaset" "EOF" "Each" "Else" "End" "EndProperty"
+ "Enum" "Environ" "Erase" "Err" "Error" "Exit" "Exp" "FV" "False" "Field"
+ "Fields" "FileAttr" "FileCopy" "FileDateTime" "FileLen" "Fix" "Font" "For"
+ "Form" "FormTemplate" "Format" "Forms" "FreeFile" "FreeLocks" "Friend"
+ "Function"
+ "Get" "GetAllSettings" "GetAttr" "GetObject" "GetSetting" "Global" "GoSub"
+ "GoTo" "Group" "Groups" "Hex" "Hour" "IIf" "IMEStatus" "IPmt" "IRR"
+ "If" "Implements" "InStr" "Input" "Int" "Integer" "Is" "IsArray" "IsDate"
+ "IsEmpty" "IsError" "IsMissing" "IsNull" "IsNumeric" "IsObject" "Kill"
+ "LBound" "LCase" "LOF" "LSet" "LTrim" "Left" "Len" "Let" "Like" "Line"
+ "Load" "LoadPicture" "LoadResData" "LoadResPicture" "LoadResString" "Loc"
+ "Lock" "Log" "Long" "Loop" "MDIForm" "MIRR" "Me" "MenuItems"
+ "MenuLine" "Mid" "Minute" "MkDir" "Month" "MsgBox" "NPV" "NPer" "Name"
+ "New" "Next" "Not" "Now" "Nothing" "Object" "Oct" "On" "Open"
+ "OpenDatabase"
+ "Operator" "Option" "Optional"
+ "Or" "PPmt" "PV" "Parameter" "Parameters" "Partition"
+ "Picture" "Pmt" "Print" "Printer" "Printers" "Private" "ProjectTemplate"
+ "Property"
+ "Properties" "Public" "Put" "QBColor" "QueryDef" "QueryDefs"
+ "RSet" "RTrim" "Randomize" "Rate" "ReDim" "Recordset" "Recordsets"
+ "RegisterDatabase" "Relation" "Relations" "Rem" "RepairDatabase"
+ "Reset" "Resume" "Return" "Right" "RmDir" "Rnd" "Rollback" "RowBuffer"
+ "SLN" "SYD" "SavePicture" "SaveSetting" "Screen" "Second" "Seek"
+ "SelBookmarks" "Select" "SelectedComponents" "SendKeys" "Set"
+ "SetAttr" "SetDataAccessOption" "SetDefaultWorkspace" "Sgn" "Shell"
+ "Sin" "Single" "Snapshot" "Space" "Spc" "Sqr" "Static" "Step" "Stop" "Str"
+ "StrComp" "StrConv" "String" "Sub" "SubMenu" "Switch" "Tab" "Table"
+ "TableDef" "TableDefs" "Tan" "Then" "Time" "TimeSerial" "TimeValue"
+ "Timer" "To" "Trim" "True" "Type" "TypeName" "UBound" "UCase" "Unload"
+ "Unlock" "Val" "Variant" "VarType" "Verb" "Weekday" "Wend"
+ "While" "Width" "With" "Workspace" "Workspaces" "Write" "Year")))
+
+(defvar visual-basic-font-lock-keywords-1
+ (eval-when-compile
+ (list
+ ;; Names of functions.
+ (list visual-basic-defun-start-regexp
+ '(1 font-lock-keyword-face nil t)
+ '(2 font-lock-keyword-face nil t)
+ '(3 font-lock-function-name-face))
+
+ ;; Statement labels
+ (cons visual-basic-label-regexp 'font-lock-keyword-face)
+
+ ;; Case values
+ ;; String-valued cases get font-lock-string-face regardless.
+ (list "^[ \t]*case[ \t]+\\([^'\n]+\\)" 1 'font-lock-keyword-face t)
+
+ ;; Any keywords you like.
+ (list (concat "\\<" (regexp-opt
+ '("FooBar" "ElseIf") t)
+ "\\>")
+ 0 'font-lock-keyword-face)
+ )))
+
+(defvar visual-basic-font-lock-keywords-2
+ (append visual-basic-font-lock-keywords-1
+ (eval-when-compile
+ `((,(concat "\\<" (regexp-opt visual-basic-all-keywords t) "\\>")
+ 0 font-lock-keyword-face)))))
+
+(defvar visual-basic-font-lock-keywords visual-basic-font-lock-keywords-1)
+
+
+(put 'visual-basic-mode 'font-lock-keywords 'visual-basic-font-lock-keywords)
+
+(defun visual-basic-mode ()
+ "A mode for editing Microsoft Visual Basic programs.
+Features automatic indentation, font locking, keyword capitalization,
+and some minor convenience functions.
+Commands:
+\\{visual-basic-mode-map}"
+ (interactive)
+ (kill-all-local-variables)
+ (use-local-map visual-basic-mode-map)
+ (setq major-mode 'visual-basic-mode)
+ (setq mode-name "Visual Basic")
+ (set-syntax-table visual-basic-mode-syntax-table)
+
+ (add-hook 'local-write-file-hooks 'visual-basic-untabify)
+
+ (setq local-abbrev-table visual-basic-mode-abbrev-table)
+ (if visual-basic-capitalize-keywords-p
+ (progn
+ (make-local-variable 'pre-abbrev-expand-hook)
+ (add-hook 'pre-abbrev-expand-hook 'visual-basic-pre-abbrev-expand-hook)
+ (abbrev-mode 1)))
+
+ (make-local-variable 'comment-start)
+ (setq comment-start "' ")
+ (make-local-variable 'comment-start-skip)
+ (setq comment-start-skip "'+ *")
+ (make-local-variable 'comment-column)
+ (setq comment-column 40)
+ (make-local-variable 'comment-end)
+ (setq comment-end "")
+
+ (make-local-variable 'indent-line-function)
+ (setq indent-line-function 'visual-basic-indent-line)
+
+ (if visual-basic-fontify-p
+ (visual-basic-enable-font-lock))
+
+ (make-local-variable 'imenu-generic-expression)
+ (setq imenu-generic-expression visual-basic-imenu-generic-expression)
+
+ (set (make-local-variable 'imenu-syntax-alist) '(("_" . "w")))
+ (set (make-local-variable 'imenu-case-fold-search) t)
+
+ ;(make-local-variable 'visual-basic-associated-files) ; doing this here means we need not check to see if it is bound later.
+ (add-hook 'find-file-hooks 'visual-basic-load-associated-files)
+
+ (run-hooks 'visual-basic-mode-hook))
+
+
+(defun visual-basic-enable-font-lock ()
+ ;; Emacs 19.29 requires a window-system else font-lock-mode errs out.
+ (cond ((or visual-basic-xemacs-p window-system)
+
+ ;; In win-emacs this sets font-lock-keywords back to nil!
+ (if visual-basic-winemacs-p
+ (font-lock-mode 1))
+
+ ;; Accomodate emacs 19.29+
+ ;; From: Simon Marshall <Simon.Marshall@esrin.esa.it>
+ (cond ((boundp 'font-lock-defaults)
+ (make-local-variable 'font-lock-defaults)
+ (setq font-lock-defaults
+ '(
+ (visual-basic-font-lock-keywords
+ visual-basic-font-lock-keywords-1
+ visual-basic-font-lock-keywords-2)
+ nil t
+ ((?\_ . "w"))
+ )))
+ (t
+ (make-local-variable 'font-lock-keywords)
+ (setq font-lock-keywords visual-basic-font-lock-keywords)))
+
+ (if visual-basic-winemacs-p
+ (font-lock-fontify-buffer)
+ (font-lock-mode 1)))
+ ))
+
+;; KJW should add some odds and bobs here to cover "end if" one way
+;; could be to create the abbreviations by removing whitespace then we
+;; could put "end if", "end with" and so on in the keyword table
+;; Another idea would be to make it intelligent enough to substitute
+;; the correct end for the construct (with, select, if)
+;; Is this what the abbrev table hook entry is for?
+(defun visual-basic-construct-keyword-abbrev-table ()
+ (if visual-basic-mode-abbrev-table
+ nil
+ (let ((words visual-basic-all-keywords)
+ (word nil)
+ (list nil))
+ (while words
+ (setq word (car words)
+ words (cdr words))
+ (setq list (cons (list (downcase word) word) list)))
+
+ (define-abbrev-table 'visual-basic-mode-abbrev-table list))))
+
+;; Would like to do this at compile-time.
+(visual-basic-construct-keyword-abbrev-table)
+
+
+(defun visual-basic-in-code-context-p ()
+ (if (fboundp 'buffer-syntactic-context) ; XEmacs function.
+ (null (buffer-syntactic-context))
+ ;; Attempt to simulate buffer-syntactic-context
+ ;; I don't know how reliable this is.
+ (let* ((beg (save-excursion
+ (beginning-of-line)
+ (point)))
+ (list
+ (parse-partial-sexp beg (point))))
+ (and (null (nth 3 list)) ; inside string.
+ (null (nth 4 list)))))) ; inside comment
+
+(defun visual-basic-pre-abbrev-expand-hook ()
+ ;; Allow our abbrevs only in a code context.
+ (setq local-abbrev-table
+ (if (visual-basic-in-code-context-p)
+ visual-basic-mode-abbrev-table)))
+
+(defun visual-basic-newline-and-indent (&optional count)
+ "Insert a newline, updating indentation."
+ (interactive)
+ (expand-abbrev)
+ (save-excursion
+ (visual-basic-indent-line))
+ (call-interactively 'newline-and-indent))
+
+(defun visual-basic-beginning-of-defun ()
+ (interactive)
+ (re-search-backward visual-basic-defun-start-regexp))
+
+(defun visual-basic-end-of-defun ()
+ (interactive)
+ (re-search-forward visual-basic-defun-end-regexp))
+
+(defun visual-basic-mark-defun ()
+ (interactive)
+ (beginning-of-line)
+ (visual-basic-end-of-defun)
+ (set-mark (point))
+ (visual-basic-beginning-of-defun)
+ (if visual-basic-xemacs-p
+ (zmacs-activate-region)))
+
+(defun visual-basic-indent-defun ()
+ (interactive)
+ (save-excursion
+ (visual-basic-mark-defun)
+ (call-interactively 'visual-basic-indent-region)))
+
+
+(defun visual-basic-fill-long-comment ()
+ "Fills block of comment lines around point."
+ ;; Derived from code in ilisp-ext.el.
+ (interactive)
+ (save-excursion
+ (beginning-of-line)
+ (let ((comment-re "^[ \t]*\\s<+[ \t]*"))
+ (if (looking-at comment-re)
+ (let ((fill-prefix
+ (buffer-substring
+ (progn (beginning-of-line) (point))
+ (match-end 0))))
+
+ (while (and (not (bobp))
+ (looking-at visual-basic-comment-regexp))
+ (forward-line -1))
+ (if (not (bobp)) (forward-line 1))
+
+ (let ((start (point)))
+
+ ;; Make all the line prefixes the same.
+ (while (and (not (eobp))
+ (looking-at comment-re))
+ (replace-match fill-prefix)
+ (forward-line 1))
+
+ (if (not (eobp))
+ (beginning-of-line))
+
+ ;; Fill using fill-prefix
+ (fill-region-as-paragraph start (point))))))))
+
+
+(defun visual-basic-fill-or-indent ()
+ "Fill long comment around point, if any, else indent current definition."
+ (interactive)
+ (cond ((save-excursion
+ (beginning-of-line)
+ (looking-at visual-basic-comment-regexp))
+ (visual-basic-fill-long-comment))
+ (t
+ (visual-basic-indent-defun))))
+
+
+(defun visual-basic-new-sub ()
+ "Insert template for a new subroutine. Repeat to cycle through alternatives."
+ (interactive)
+ (beginning-of-line)
+ (let ((templates (cons visual-basic-blank-regexp
+ visual-basic-defn-templates))
+ (tem nil)
+ (bound (point)))
+ (while templates
+ (setq tem (car templates)
+ templates (cdr templates))
+ (cond ((looking-at tem)
+ (replace-match (or (car templates)
+ ""))
+ (setq templates nil))))
+
+ (search-backward "()" bound t)))
+
+
+(defun visual-basic-untabify ()
+ "Do not allow any tabs into the file."
+ (if (eq major-mode 'visual-basic-mode)
+ (untabify (point-min) (point-max)))
+ nil)
+
+(defun visual-basic-default-tag ()
+ (if (and (not (bobp))
+ (save-excursion
+ (backward-sexp)
+ (looking-at "\\w")))
+ (backward-word 1))
+ (let ((s (point))
+ (e (save-excursion
+ (forward-sexp)
+ (point))))
+ (buffer-substring s e)))
+
+(defun visual-basic-grep (tag)
+ "Search BASIC source files in current directory for TAG."
+ (interactive
+ (list (let* ((def (visual-basic-default-tag))
+ (tag (read-string
+ (format "Grep for [%s]: " def))))
+ (if (string= tag "") def tag))))
+ (grep (format "grep -n %s %s" tag visual-basic-wild-files)))
+
+
+;;; IDE Connection.
+
+(defun visual-basic-buffer-project-file ()
+ "Return a guess as to the project file associated with the current buffer."
+ (car (directory-files (file-name-directory (buffer-file-name)) t "\\.vbp")))
+
+(defun visual-basic-start-ide ()
+ "Start Visual Basic (or your favorite IDE, (after Emacs, of course))
+on the first project file in the current directory.
+Note: it's not a good idea to leave Visual Basic running while you
+are editing in Emacs, since Visual Basic has no provision for reloading
+changed files."
+ (interactive)
+ (let (file)
+ (cond ((null visual-basic-ide-pathname)
+ (error "No pathname set for Visual Basic. See visual-basic-ide-pathname"))
+ ((null (setq file (visual-basic-buffer-project-file)))
+ (error "No project file found"))
+ ((fboundp 'win-exec)
+ (iconify-emacs)
+ (win-exec visual-basic-ide-pathname 'win-show-normal file))
+ ((fboundp 'start-process)
+ (iconify-frame (selected-frame))
+ (start-process "*VisualBasic*" nil visual-basic-ide-pathname file))
+ (t
+ (error "No way to spawn process!")))))
+
+
+
+;;; Indentation-related stuff.
+
+(defun visual-basic-indent-region (start end)
+ "Perform visual-basic-indent-line on each line in region."
+ (interactive "r")
+ (save-excursion
+ (goto-char start)
+ (beginning-of-line)
+ (while (and (not (eobp))
+ (< (point) end))
+ (if (not (looking-at visual-basic-blank-regexp))
+ (visual-basic-indent-line))
+ (forward-line 1)))
+
+ (cond ((fboundp 'zmacs-deactivate-region)
+ (zmacs-deactivate-region))
+ ((fboundp 'deactivate-mark)
+ (deactivate-mark))))
+
+
+
+(defun visual-basic-previous-line-of-code ()
+ (if (not (bobp))
+ (forward-line -1)) ; previous-line depends on goal column
+ (while (and (not (bobp))
+ (or (looking-at visual-basic-blank-regexp)
+ (looking-at visual-basic-comment-regexp)))
+ (forward-line -1)))
+
+
+(defun visual-basic-find-original-statement ()
+ "If the current line is a continuation, move back to the original stmt."
+ (let ((here (point)))
+ (visual-basic-previous-line-of-code)
+ (while (and (not (bobp))
+ (looking-at visual-basic-continuation-regexp))
+ (setq here (point))
+ (visual-basic-previous-line-of-code))
+ (goto-char here)))
+
+(defun visual-basic-find-matching-stmt (open-regexp close-regexp)
+ ;; Searching backwards
+ (let ((level 0))
+ (while (and (>= level 0) (not (bobp)))
+ (visual-basic-previous-line-of-code)
+ (visual-basic-find-original-statement)
+ (cond ((looking-at close-regexp)
+ (setq level (+ level 1)))
+ ((looking-at open-regexp)
+ (setq level (- level 1)))))))
+
+(defun visual-basic-find-matching-if ()
+ (visual-basic-find-matching-stmt
+ visual-basic-if-regexp visual-basic-endif-regexp))
+
+(defun visual-basic-find-matching-select ()
+ (visual-basic-find-matching-stmt
+ visual-basic-select-regexp visual-basic-select-end-regexp))
+
+(defun visual-basic-find-matching-for ()
+ (visual-basic-find-matching-stmt
+ visual-basic-for-regexp visual-basic-next-regexp))
+
+(defun visual-basic-find-matching-do ()
+ (visual-basic-find-matching-stmt
+ visual-basic-do-regexp visual-basic-loop-regexp))
+
+(defun visual-basic-find-matching-while ()
+ (visual-basic-find-matching-stmt
+ visual-basic-while-regexp visual-basic-wend-regexp))
+
+(defun visual-basic-find-matching-with ()
+ (visual-basic-find-matching-stmt
+ visual-basic-with-regexp visual-basic-end-with-regexp))
+
+;;; If this fails it must return the indent of the line preceding the
+;;; end not the first line because end without matching begin is a
+;;; normal simple statement
+(defun visual-basic-find-matching-begin ()
+ (let ((original-point (point)))
+ (visual-basic-find-matching-stmt visual-basic-begin-regexp
+ visual-basic-end-begin-regexp)
+ (if (bobp) ;failed to find a matching begin so assume that it is
+ ;an end statement instead and use the indent of the
+ ;preceding line.
+ (progn (goto-char original-point)
+ (visual-basic-previous-line-of-code)))))
+
+
+(defun visual-basic-calculate-indent ()
+ (let ((original-point (point)))
+ (save-excursion
+ (beginning-of-line)
+ ;; Some cases depend only on where we are now.
+ (cond ((or (looking-at visual-basic-defun-start-regexp)
+ (looking-at visual-basic-label-regexp)
+ (looking-at visual-basic-defun-end-regexp))
+ 0)
+
+ ;; The outdenting stmts, which simply match their original.
+ ((or (looking-at visual-basic-else-regexp)
+ (looking-at visual-basic-endif-regexp))
+ (visual-basic-find-matching-if)
+ (current-indentation))
+
+ ;; All the other matching pairs act alike.
+ ((looking-at visual-basic-next-regexp) ; for/next
+ (visual-basic-find-matching-for)
+ (current-indentation))
+
+ ((looking-at visual-basic-loop-regexp) ; do/loop
+ (visual-basic-find-matching-do)
+ (current-indentation))
+
+ ((looking-at visual-basic-wend-regexp) ; while/wend
+ (visual-basic-find-matching-while)
+ (current-indentation))
+
+ ((looking-at visual-basic-end-with-regexp) ; with/end with
+ (visual-basic-find-matching-with)
+ (current-indentation))
+
+ ((looking-at visual-basic-select-end-regexp) ; select case/end select
+ (visual-basic-find-matching-select)
+ (current-indentation))
+
+ ;; A case of a select is somewhat special.
+ ((looking-at visual-basic-case-regexp)
+ (visual-basic-find-matching-select)
+ (+ (current-indentation) visual-basic-mode-indent))
+
+ ;; Added KJW: Make sure that this comes after the cases
+ ;; for if..endif, end select because end-regexp will also
+ ;; match "end select" etc.
+ ((looking-at visual-basic-end-begin-regexp) ; begin/end
+ (visual-basic-find-matching-begin)
+ (current-indentation))
+
+ (t
+ ;; Other cases which depend on the previous line.
+ (visual-basic-previous-line-of-code)
+
+ ;; Skip over label lines, which always have 0 indent.
+ (while (looking-at visual-basic-label-regexp)
+ (visual-basic-previous-line-of-code))
+
+ (cond
+ ((looking-at visual-basic-continuation-regexp)
+ (visual-basic-find-original-statement)
+ ;; Indent continuation line under matching open paren,
+ ;; or else one word in.
+ (let* ((orig-stmt (point))
+ (matching-open-paren
+ (condition-case ()
+ (save-excursion
+ (goto-char original-point)
+ (beginning-of-line)
+ (backward-up-list 1)
+ ;; Only if point is now w/in cont. block.
+ (if (<= orig-stmt (point))
+ (current-column)))
+ (error nil))))
+ (cond (matching-open-paren
+ (1+ matching-open-paren))
+ (t
+ ;; Else, after first word on original line.
+ (back-to-indentation)
+ (forward-word 1)
+ (while (looking-at "[ \t]")
+ (forward-char 1))
+ (current-column)))))
+ (t
+ (visual-basic-find-original-statement)
+
+ (let ((indent (current-indentation)))
+ ;; All the various +indent regexps.
+ (cond ((looking-at visual-basic-defun-start-regexp)
+ (+ indent visual-basic-mode-indent))
+
+ ((and (or (looking-at visual-basic-if-regexp)
+ (looking-at visual-basic-else-regexp))
+ (not (and visual-basic-allow-single-line-if
+ (looking-at visual-basic-ifthen-regexp))))
+ (+ indent visual-basic-mode-indent))
+
+ ((or (looking-at visual-basic-select-regexp)
+ (looking-at visual-basic-case-regexp))
+ (+ indent visual-basic-mode-indent))
+
+ ((or (looking-at visual-basic-do-regexp)
+ (looking-at visual-basic-for-regexp)
+ (looking-at visual-basic-while-regexp)
+ (looking-at visual-basic-with-regexp)
+ (looking-at visual-basic-begin-regexp))
+ (+ indent visual-basic-mode-indent))
+
+ (t
+ ;; By default, just copy indent from prev line.
+ indent))))))))))
+
+(defun visual-basic-indent-to-column (col)
+ (let* ((bol (save-excursion
+ (beginning-of-line)
+ (point)))
+ (point-in-whitespace
+ (<= (point) (+ bol (current-indentation))))
+ (blank-line-p
+ (save-excursion
+ (beginning-of-line)
+ (looking-at visual-basic-blank-regexp))))
+
+ (cond ((/= col (current-indentation))
+ (save-excursion
+ (beginning-of-line)
+ (back-to-indentation)
+ (delete-region bol (point))
+ (indent-to col))))
+
+ ;; If point was in the whitespace, move back-to-indentation.
+ (cond (blank-line-p
+ (end-of-line))
+ (point-in-whitespace
+ (back-to-indentation)))))
+
+(defun visual-basic-indent-line ()
+ "Indent current line for BASIC."
+ (interactive)
+ (visual-basic-indent-to-column (visual-basic-calculate-indent)))
+
+(defun visual-basic-split-line ()
+ "Split line at point, adding continuation character or continuing a comment.
+In Abbrev mode, any abbrev before point will be expanded."
+ (interactive)
+ (let ((pps-list (parse-partial-sexp (save-excursion
+ (beginning-of-line)
+ (point))
+ (point))))
+ ;; Dispatch on syntax at this position.
+ (cond ((equal t (nth 4 pps-list)) ; in comment
+ (indent-new-comment-line))
+ ((equal t (nth 4 pps-list)) ; in string
+ (error "Can't break line inside a string"))
+ (t (just-one-space) ; leading space on next line
+ ; doesn't count, sigh
+ (insert "_")
+ (visual-basic-newline-and-indent)))))
+
+(provide 'visual-basic-mode)
+
+
+;;; Some experimental functions
+
+;;; Load associated files listed in the file local variables block
+(defun visual-basic-load-associated-files ()
+ "Load files that are useful to have around when editing the source of the file that has just been loaded.
+The file must have a local variable that lists the files to be loaded.
+If the file name is relative it is relative to the directory
+containing the current buffer. If the file is already loaded nothing
+happens, this prevents circular references causing trouble. After an
+associated file is loaded its associated files list will be
+processed."
+ (if (boundp 'visual-basic-associated-files)
+ (let ((files visual-basic-associated-files)
+ (file nil))
+ (while files
+ (setq file (car files)
+ files (cdr files))
+ (message "Load associated file: %s" file)
+ (visual-basic-load-file-ifnotloaded file default-directory)))))
+
+
+
+(defun visual-basic-load-file-ifnotloaded (file default-directory)
+ "Load file if not already loaded.
+If file is relative then default-directory provides the path"
+ (let((file-absolute (expand-file-name file default-directory)))
+ (if (get-file-buffer file-absolute); don't do anything if the buffer is already loaded
+ ()
+ (find-file-noselect file-absolute ))))
+
+
+
+
+
+
+
+;(setq visual-basic-
+; (defun visual-basic-standardize-spacing()
+; "Scan buffer and add or remove spaces so that keywords are separated by single spaces. Like it or not your code will look like this if you edit it in VB so we might as well do it here."
+; (interactive)
+; (save-excursion
+; (
+
+;;; visual-basic-mode.el ends here
--- /dev/null
+package provide Display 1.0
+package require Tcl 8.4
+
+namespace eval ::Display {
+ namespace export \
+ display \
+ verbose \
+ debug \
+ set_debug \
+ set_verbose
+
+ set debug 0
+ set verbose 0
+}
+
+proc ::Display::display {msg} {
+ puts $msg
+}
+
+proc ::Display::debug {msg} {
+ global debug
+
+ if {$Display::debug} {
+ display "DEBUG: $msg"
+ }
+}
+
+proc ::Display::error {msg} {
+ display "ERROR: $msg"
+ exit 1
+}
+
+proc ::Display::verbose {msg} {
+ global verbose
+
+ if {$Display::verbose} {
+ display $msg
+ }
+}
+
+proc ::Display::set_debug {newValue} {
+ global debug
+
+ set oldValue $Display::debug
+
+ set Display::debug $newValue
+
+ return $oldValue
+}
+
+proc ::Display::set_verbose {newValue} {
+ global verbose
+
+ set oldValue $Display::verbose
+
+ set Display::verbose $newValue
+
+ return $oldValue
+}
--- /dev/null
+.-_hist
+.cvsignore
--- /dev/null
+#!/usr/bin/perl
+use strict;
+use warnings;
+
+use FindBin;
+use Term::ANSIColor qw(:constants);
+
+my $libs;
+
+BEGIN {
+ $libs = $ENV{SITE_PERLLIB} ? $ENV{SITE_PERLLIB} : "$FindBin::Bin/../lib";
+
+ die "Unable to find libraries\n"
+ unless -d $libs;
+} # BEGIN
+
+use lib $libs;
+
+use Clearcase;
+use Display;
+
+my ($status, @output) = $Clearcase::CC->execute ('-ver');
+
+error 'Clearcase is not installed on this system', 1
+ if $status;
+
+display YELLOW . "Global Clearcase Variables\n" . RESET;
+
+my $view_drive = $Clearcase::VIEW_DRIVE;
+my $vob_mount = $Clearcase::VOB_MOUNT;
+my $win_vob_prefix = $Clearcase::WIN_VOB_PREFIX;
+my $vobtag_prefix = $Clearcase::VOBTAG_PREFIX;
+my $countdb = $Clearcase::COUNTDB;
+
+display MAGENTA . "View Drive:\t\t" . RESET . $view_drive;
+display MAGENTA . "VOB Mount:\t\t" . RESET . $vob_mount;
+display MAGENTA . "Windows VOB prefix:\t" . RESET . $win_vob_prefix;
+display MAGENTA . "VOB Tag Prefix:\t\t" . RESET . $vobtag_prefix;
+display MAGENTA . "CountDB:\t\t" . RESET . $countdb;
+
+display CYAN . "\nGlobal Clearcase Configuration\n" . RESET;
+
+display MAGENTA . "Client:\t\t\t" . RESET . $Clearcase::CC->client;
+display MAGENTA . "Hardware type:\t\t" . RESET . $Clearcase::CC->hardware_type;
+display MAGENTA . "License host:\t\t" . RESET . $Clearcase::CC->license_host;
+display MAGENTA . "OS:\t\t\t" . RESET . $Clearcase::CC->os;
+display MAGENTA . "Region:\t\t\t" . RESET . $Clearcase::CC->region;
+display MAGENTA . "Registry host:\t\t" . RESET . $Clearcase::CC->registry_host;
+display MAGENTA . "Sitename:\t\t" . RESET . $Clearcase::CC->sitename;
+display MAGENTA . "Version:\t\t" . RESET . $Clearcase::CC->version;
+
+display GREEN . "\nCleartool Access\n" . RESET;
+
+display_nolf MAGENTA . "Views:\t" . RESET;
+
+($status, @output) = $Clearcase::CC->execute ("lsview -s");
+
+display scalar @output;
+
+display_nolf MAGENTA . "VOBs:\t" . RESET;
+
+($status, @output) = $Clearcase::CC->execute ("lsvob -s");
+
+display scalar @output;
+
+($status, @output) = $Clearcase::CC->execute ("invalid command");
+
+display $_ foreach (@output);
--- /dev/null
+#!/usr/bin/perl
+use strict;
+use warnings;
+
+=pod
+
+=head1 NAME $RCSfile: testclearquest.pl,v $
+
+Test the Clearquest libary
+
+This script tests various functions of the Clearquest library
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 2.8 $
+
+=item Created:
+
+Mon Nov 12 16:50:44 PST 2012
+
+=item Modified:
+
+$Date: 2013/03/14 23:39:39 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage: testclearquest.pl [-u|sage] [-v|erbose] [-d|ebug]
+ [-get] [-add] [-modify] [-change] [-delete]
+ [-username <username>] [-password <password>]
+ [-database <dbname>] [-dbset <dbset>]
+ [-module] [-server <server>] [-port <port>]
+
+ Where:
+ -usa|ge: Displays usage
+ -v|erbose: Be verbose
+ -de|bug: Output debug messages
+
+ -get: Test get
+ -add: Test add
+ -modify: Test modify
+ -change: Test change
+ -delete: Test delete
+
+ -use|rname: Username to open database with (Default: from config file)
+ -p|assword: Password to open database with (Default: from config file)
+ -da|tabase: Database to open (Default: from config file)
+ -db|set: Database Set to use (Default: from config file)
+ -m|odule: Type of Clearquest module to use. Must be one of 'api',
+ 'client', or 'rest'. The 'api' module can only be used if
+ Clearquest is installed locally. The 'client' module can only
+ be successful if a corresponding server is running. And the
+ 'rest' module can only be used if a CQ Web server has been set
+ up and configured (Default: rest)
+ -s|erver: For module = client or rest this is the name of the server that
+ will be providing the service
+ -p|ort: For module = client, this is the point on the server to talk
+ through.
+
+
+=head1 Options
+
+Options are keep in the cq.conf file in etc. They specify the default options
+listed below. Or you can export the option name to the env(1) to override the
+defaults in cq.conf. Finally you can programmatically set the options when you
+call new by passing in a %parms hash. To specify the %parms hash key remove the
+CQ_ portion and lc the rest.
+
+=for html <blockquote>
+
+=over
+
+=item CQ_SERVER
+
+Clearquest server to talk to (Default: From cq.conf)
+
+=item CQ_PORT
+
+Port to connect to (Default: From cq.conf)
+
+=item CQ_WEBHOST
+
+The web host to contact with leading http:// (Default: From cq.conf)
+
+=item CQ_DATABASE
+
+Name of database to connect to (Default: From cq.conf)
+
+=item CQ_USERNAME
+
+User name to connect as (Default: From cq.conf)
+
+=item CQ_PASSWORD
+
+Password for CQREST_USERNAME (Default: From cq.conf)
+
+=item CQ_DBSET
+
+Database Set name (Default: From cq.conf)
+
+=back
+
+=cut
+
+use FindBin;
+use Getopt::Long;
+
+use lib "$FindBin::Bin/../lib";
+
+use Clearquest;
+use Display;
+use TimeUtils;
+use Utils;
+
+my ($cq, %opts);
+
+sub displayRecord (%) {
+ my (%record) = @_;
+
+ display '-' x 79;
+
+ foreach (keys %record) {
+ display_nolf "$_: ";
+
+ if (ref $record{$_} eq 'ARRAY') {
+ display join ", ", @{$record{$_}};
+ } elsif ($record{$_}) {
+ display $record{$_};
+ } else {
+ display "<undef>";
+ } # if
+ } # foreach
+
+ return;
+} # displayRecord
+
+sub displayResults (@) {
+ my (@records) = @_;
+
+ if (@records) {
+ displayRecord %$_ foreach (@records);
+ } else {
+ display "Did not find any records";
+ } # if
+
+ return;
+} # displayResults
+
+sub testGetRecord ($$;@) {
+ my ($table, $key, @fields) = @_;
+
+ my $startTime = time;
+
+ display "Testing get table: $table key: $key";
+
+ displayRecord $cq->get ($table, $key, @fields);
+
+ display_duration $startTime;
+
+ return;
+} # testGetRecord
+
+sub testFindRecord ($$;@) {
+ my ($table, $condition, @fields) = @_;
+
+ my $startTime = time;
+
+ display "Testing find table: $table condition: $condition";
+
+ my ($result, $nbrRecs) = $cq->find ($table, $condition, @fields);
+
+ display "$nbrRecs records qualified";
+
+ while (my %record = $cq->getNext ($result)) {
+ displayRecord %record;
+ } # while
+
+ display_duration $startTime;
+
+ return;
+} # testFindRecord
+
+sub testModifyRecord ($$;%) {
+ my ($table, $key, %update) = @_;
+
+ my $startTime = time;
+
+ display "Testing modify table: $table key: $key";
+
+ $cq->modify ($table, $key, undef, \%update);
+
+ $cq->checkErr;
+
+ display_duration $startTime;
+
+ return;
+} # testModifyRecord
+
+sub testChangeState ($$) {
+ my ($table, $key) = @_;
+
+ my $startTime = time;
+
+ my %record = $cq->get ($table, $key, ('State'));
+
+ $cq->checkErr ("Unable to find $table where key = $key");
+
+ return if $cq->error;
+
+ my ($action, %update);
+
+ if ($record{State} eq 'Assigned') {
+ $action = 'AdminAssignToSubmit';
+ $update{Stability_Issue} = 'User Fault';
+ } else {
+ $action = 'Assign';
+ $update{Stability_Issue} = 'Assert';
+ } # if
+
+ display "Testing change state table: $table key: $key action: $action";
+
+ $cq->modify ($table, $key, $action, \%update);
+
+ $cq->checkErr;
+
+ display_duration $startTime;
+
+ return;
+} # testChangeState
+
+sub testAddRecord ($%) {
+ my ($table, %record) = @_;
+
+ my $startTime = time;
+
+ display "Testing adding table: $table";
+
+ $cq->add ($table, \%record, qw(Projects VersionStr));
+
+ $cq->checkErr;
+
+ display_duration $startTime;
+
+ return;
+} # testAddRecord
+
+sub testDeleteRecord ($$) {
+ my ($table, $key) = @_;
+
+ my $startTime = time;
+
+ display "Testing deleting table: $table key: $key";
+
+ $cq->delete ($table, $key);
+
+ $cq->checkErr;
+
+ display_duration $startTime;
+
+ return;
+} # testDeleteRecord
+
+## Main
+GetOptions (
+ \%opts,
+ usage => sub { Usage },
+ verbose => sub { set_verbose },
+ debug => sub { set_debug },
+ 'get',
+ 'add',
+ 'modify',
+ 'change',
+ 'delete',
+ 'module=s',
+ 'username=s',
+ 'password=s',
+ 'database=s',
+ 'dbset=s',
+ 'server=s',
+ 'port=i',
+) || Usage;
+
+my $processStartTime = time;
+
+local $| = 1;
+
+# Translate any options to ones that the lib understands
+$opts{CQ_USERNAME} = delete $opts{username};
+$opts{CQ_PASSWORD} = delete $opts{password};
+$opts{CQ_DATABASE} = delete $opts{database};
+$opts{CQ_DBSET} = delete $opts{dbset};
+$opts{CQ_SERVER} = delete $opts{server};
+$opts{CQ_PORT} = delete $opts{port};
+$opts{CQ_MODULE} = delete $opts{module};
+
+# If nothing is set then do everything
+unless ($opts{get} or
+ $opts{add} or
+ $opts{modify} or
+ $opts{change} or
+ $opts{delete}
+ ) {
+ $opts{get} = $opts{add} = $opts{modify} = $opts{change} = 1;
+} # unless
+
+# If we are testing add or delete then toggle on the other one
+$opts{delete} = 1 if $opts{add};
+$opts{add} = 1 if $opts{delete};
+
+my $startTime = time;
+
+$cq = Clearquest->new (%opts);
+
+display_nolf 'Connecting to Clearquest database ' . $cq->connection;
+
+unless ($cq->connect) {
+ $cq->checkErr ('Unable to connect to database ' . $cq->connection);
+
+ if ($cq->module eq 'client') {
+ display 'Unable to connect to server '
+ . $cq->server ()
+ . ':'
+ . $cq->port ();
+ } # if
+
+ exit $cq->error;
+} else {
+ display '';
+ display_duration $startTime;
+} # unless
+
+$cq->setOpts (emptyStringForUndef => 1);
+
+if ($opts{get}) {
+ # Get record by key
+ testGetRecord 'Project', 'Athena';
+
+ # Get record by condition
+ testFindRecord 'VersionInfo', 'Deprecated = 1';
+
+ # Get record by key with field list
+ testFindRecord 'VersionInfo', 'VersionStr = 1.0', ('VersionStr', 'Deprecated');
+
+ # Get record by condition with field list
+ testFindRecord 'CategorySub', 'Category="Software"', ('Category', 'CategoryType', 'SubCategory');
+} # if
+
+if ($opts{add}) {
+ # Add a record
+ testAddRecord 'VersionInfo', (
+ VersionStr => '2.0',
+ Projects => ['Island', '21331', 'Hera'],
+ Visibility => 'Nokia Corporation',
+ );
+} # if
+
+if ($opts{modify}) {
+ # Modify a record
+ testModifyRecord ('VersionInfo', '1.0', (
+ Deprecated => 1,
+ Projects => ['Island', 'Athena'],
+ ));
+} # if
+
+if ($opts{change}) {
+ # Change State
+ testChangeState 'Defect', 'apd00000034';
+} # if
+
+if ($opts{add}) {
+ # Delete that record
+ testDeleteRecord 'VersionInfo', '2.0';
+} # if
+
+display_nolf 'Total process time ';
+
+display_duration $processStartTime;
--- /dev/null
+#!cqperl
+use strict;
+use warnings;
+
+use FindBin;
+
+use lib "$FindBin::Bin/../lib";
+
+use Clearquest::Client;
+use Display;
+use TimeUtils;
+
+$| = 1;
+
+# Let's time this...
+my $startTime = time;
+
+my $cq = Clearquest::Client->new;
+
+my $dbname = $cq->username () . '@' . $cq->database () . '/' . $cq->dbset ();
+
+display_nolf "Connecting to Clearquest database $dbname";
+
+unless ($cq->connect) {
+ display ' Failed!';
+
+ error "Unable to connect to database $dbname", 1;
+} # unless
+
+display_duration $startTime;
+
+my ($result, $nbrRecs) = $cq->find ('defect', 'assert == 0', ('id', 'title'));
+
+while (my %record = $cq->getNext ($result)) {
+ display "$_: $record{$_}" foreach (sort keys %record);
+} # while
+
+display 'done';
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl
+use strict;
+use warnings;
+
+use FindBin;
+
+use lib "$FindBin::Bin/../lib";
+
+use CmdLine;
+use Display;
+use Term::ANSIColor qw (color);
+
+my $me = $FindBin::Script;
+ $me =~ s/\.pl$//;
+
+my $prompt = color ('BOLD CYAN') . "$me:" . color ('RESET');
+
+$CmdLine::cmdline->set_prompt ($prompt);
+
+my ($line, $result);
+
+while (($line, $result) = $CmdLine::cmdline->get) {
+ last unless defined $line;
+ last if $line =~ /exit|quit/i;
+
+ display "Would have executed $line"
+ if $line !~ /^\s*$/;
+} # while
+
+display 'done';
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl
+use strict;
+use warnings;
+
+use FindBin;
+use Term::ANSIColor qw(:constants);
+
+my $libs;
+
+BEGIN {
+ $libs = $ENV{SITE_PERLLIB} ? $ENV{SITE_PERLLIB} : "$FindBin::Bin/../lib";
+
+ die "Unable to find libraries\n" if !$libs and !-d $libs;
+} # BEGIN
+
+use lib $libs;
+
+use Clearcase;
+use Clearcase::Element;
+use Display;
+
+error "Usage: $0 <pname>", 1 if !$ARGV[0];
+
+my $element = new Clearcase::Element (pname => $ARGV[0]);
+
+display MAGENTA . "Element:\t" . RESET . $element->pname;
+display MAGENTA . "Version:\t" . RESET . $element->version;
+display MAGENTA . "Pred:\t\t" . RESET . $element->pred;
+
+display MAGENTA . "Activities:" . RESET;
+
+if (my %activities = $element->activities) {
+ display "\t\t$_: $activities{$_}" foreach (keys %activities);
+} else {
+ display CYAN . "\t\tNone" . RESET;
+} # if
+
+display MAGENTA . "Attributes:" . RESET;
+
+if (my %attributes = $element->attributes) {
+ display "\t\t$_=$attributes{$_}" foreach (keys %attributes);
+} else {
+ display CYAN . "\t\tNone" . RESET;
+} # if
+
+display MAGENTA . "Hyperlinks:" . RESET;
+
+if (my @hyperlinks = $element->hyperlinks) {
+ display "\t\t$_" foreach (@hyperlinks);
+} else {
+ display CYAN . "\t\tNone" . RESET;
+} # if
+
+display MAGENTA . "Comments:" . RESET . $element->comments;
+display MAGENTA . "Create_date:\t" . RESET . $element->create_date;
+display MAGENTA . "User:\t\t" . RESET . $element->user;
+display MAGENTA . "Group:\t\t" . RESET . $element->group;
+display MAGENTA . "User_mode:\t" . RESET . $element->user_mode;
+display MAGENTA . "Group_mode:\t" . RESET . $element->group_mode;
+display MAGENTA . "Other_mode:\t" . RESET . $element->other_mode;
+display MAGENTA . "Mode:\t\t" . RESET . $element->mode;
+
+display MAGENTA . "Labels:" . RESET;
+
+if (my @labels = $element->labels) {
+ display "\t\t$_" foreach (@labels);
+} else {
+ display CYAN . "\t\tNone" . RESET;
+} # if
+
+display MAGENTA . "Rule:\t\t" . RESET . $element->rule;
+display MAGENTA . "Xname:\t\t" . RESET . $element->xname;
--- /dev/null
+#!/usr/bin/env cqperl
+################################################################################
+#
+# File: $RCSfile: testmail.pl,v $
+# Revision: $Revision: 1.1 $
+# Description: Tests Mail.pm
+# Author: Andrew@DeFaria.com
+# Created: Wed Aug 1 09:16:42 MST 2007
+# Modified: $Date: 2007/12/07 05:52:36 $
+# Language: perl
+#
+# (c) Copyright 2007, ClearSCM, Inc., all rights reserved
+#
+################################################################################
+use strict;
+use warnings;
+
+use FindBin;
+
+my $libs;
+
+BEGIN {
+ $libs = $ENV{SITE_PERLLIB} ? $ENV{SITE_PERLLIB} : "$FindBin::Bin/../lib";
+
+ die "Unable to find libraries\n" if !$libs;
+}
+
+use lib $libs;
+
+use Mail;
+
+my $data = <<END;
+<table cellspacing=0 border=1>
+ <tbody>
+ <tr>
+ <td align=center>RANCQ00008837</td>
+ <td>Add new VOB to other projects</td>
+ <td align=center>NeedingInfo</td>
+ <td align=center>p6258c</td>
+ <td align=center>p5602c</td>
+ <td align=center>2007-07-26 15:19:53</td>
+ </tr>
+ <tr>
+ <td align=center>RANCQ00012317</td>
+ <td>RoseRT Crashing</td>
+ <td align=center>NeedingInfo</td>
+ <td align=center>p6258c</td>
+ <td align=center>p29353</td>
+ <td align=center>2007-07-18 11:49:57</td>
+ </tr>
+ <tr>
+ <td align=center>RANCQ00012821</td>
+ <td>http://ranweb requests</td>
+ <td align=center>Verifying</td>
+ <td align=center>p6258c</td>
+ <td align=center>p6001c</td>
+ <td align=center>2007-07-26 15:40:47</td>
+ </tr>
+ <tr>
+ <td align=center>RANCQ00012830</td>
+ <td>Not all errors are being reported when doing rebase from UCM GUI.</td>
+ <td align=center>NeedingInfo</td>
+ <td align=center>p6258c</td>
+ <td align=center>p57413</td>
+ <td align=center>2007-07-26 11:40:37</td>
+ </tr>
+ </tbody>
+</table>
+END
+
+my $footing = <<END;
+--
+Clearquest Team
+END
+
+my $heading = "<h1>Helpdesk Report as of 20070801</h1>";
+my $subject = "Helpdesk Report";
+my $to = "andrew.defaria\@gdc4s.com";
+
+# Main
+mail (
+ "to" => $to,
+ "subject" => $subject,
+ "mode" => "html",
+ "heading" => $heading,
+ "footing" => $footing,
+ "data" => $data,
+)
--- /dev/null
+#!/usr/brcm/ba/bin/perl
+use strict;
+use warnings;
+
+use FindBin;
+use Getopt::Long;
+
+use lib "$FindBin::Bin/../lib";
+
+use Clearquest::REST;
+use Display;
+use Utils;
+
+my $cq;
+
+=pod
+
+Usage $FindBin::Script: [-get] [-add] [-modify] [-change] [-delete]
+
+=cut
+
+END {
+ # Always remember to call disconnect for any instanciated Clearquest::REST
+ # object
+ $cq->disconnect if $cq;
+} # END
+
+sub displayRecord (%) {
+ my (%record) = @_;
+
+ display '-' x 79;
+
+ foreach (keys %record) {
+ display_nolf "$_: ";
+
+ if (ref $record{$_} eq 'ARRAY') {
+ display join ", ", @{$record{$_}};
+ } elsif ($record{$_}) {
+ display $record{$_};
+ } else {
+ display "<undef>";
+ } # if
+ } # foreach
+} # displayRecord
+
+sub displayResults (@) {
+ my (@records) = @_;
+
+ if (@records) {
+ displayRecord %$_ foreach (@records);
+ } else {
+ display "Did not find any records";
+ } # if
+} # displayResults
+
+sub testGetRecord ($$;@) {
+ my ($table, $key, @fields) = @_;
+
+ display "Testing get table: $table key: $key";
+
+ displayRecord $cq->get ($table, $key, @fields);
+} # testGetRecord
+
+sub testFindRecord ($$;@) {
+ my ($table, $condition, @fields) = @_;
+
+ display "Testing find table: $table condition: $condition";
+
+ my ($result, $nbrRecs) = $cq->find ($table, $condition, @fields);
+
+ display "$nbrRecs records qualified";
+
+ while (my %record = $cq->getNext ($result)) {
+ displayRecord %record;
+ } # while
+} # testFindRecord
+
+sub testModifyRecord ($$;%) {
+ my ($table, $key, %update) = @_;
+
+ display "Testing modify table: $table key: $key";
+
+ my $errmsg = $cq->modify ($table, $key, undef, %update);
+
+ display $errmsg;
+} # testModifyRecord
+
+sub testChangeState ($$) {
+ my ($table, $key) = @_;
+
+ my %record = $cq->get ($table, $key, ('State'));
+
+ my ($action, %update);
+
+ if ($record{State} eq 'Assigned') {
+ $action = 'AdminAssignToSubmit';
+ $update{Stability_Issue} = 'User Fault';
+ } else {
+ $action = 'Assign';
+ $update{Stability_Issue} = 'Assert';
+ } # if
+
+ display "Testing change state table: $table key: $key action: $action";
+
+ my $errmsg = $cq->modify ($table, $key, $action, %update);
+
+ display $errmsg;
+} # testChangeState
+
+sub testAddRecord ($%) {
+ my ($table, %record) = @_;
+
+ display "Testing adding table: $table";
+
+ my $errmsg = $cq->add ($table, %record);
+
+ display $errmsg;
+} # testAddRecord
+
+sub testDeleteRecord ($$) {
+ my ($table, $key) = @_;
+
+ display "Testing deleting table: $table key: $key";
+
+ my $errmsg = $cq->delete ($table, $key);
+
+ display $errmsg;
+} # testDeleteRecord
+
+my %opts;
+
+GetOptions (
+ \%opts,
+ 'get',
+ 'add',
+ 'modify',
+ 'change',
+ 'delete'
+) || Usage;
+
+# If nothing is set then do everything
+unless ($opts{get} or
+ $opts{add} or
+ $opts{modify} or
+ $opts{change} or
+ $opts{delete}
+ ) {
+ $opts{get} = $opts{add} = $opts{modify} = $opts{change} = 1;
+} # unless
+
+# If we are testing add or delete then toggle on the other one
+$opts{delete} = 1 if $opts{add};
+$opts{add} = 1 if $opts{delete};
+
+$cq = Clearquest::REST->new;
+
+if ($opts{get}) {
+ # Get record by key
+ testGetRecord 'Project', 'Athena';
+
+ # Get record by condition
+ testFindRecord 'VersionInfo', 'Deprecated = 1';
+
+ # Get record by key with field list
+ testFindRecord 'VersionInfo', 'VersionStr = 1.0', ('VersionStr', 'Deprecated');
+
+ # Get record by condition with field list
+ testFindRecord 'CategorySub', 'Category="Customer-HW"', ('Category', 'CategoryType', 'SubCategory');
+} # if
+
+if ($opts{add}) {
+ # Add a record
+ testAddRecord 'VersionInfo', (
+ VersionStr => '2.0',
+ Projects => {
+ Project => ['Island', '21331', 'Hera'],
+ },
+ Visibility => 'Nokia Corporation',
+ );
+} # if
+
+if ($opts{modify}) {
+ # Modify a record
+ testModifyRecord ('VersionInfo', '1.0', (
+ Deprecated => 1,
+ Projects => {
+ Project => ['Island', 'Athena'],
+ },
+ ));
+} # if
+
+if ($opts{change}) {
+ # Change State
+ testChangeState 'Defect', 't_sbx00018584';
+} # if
+
+if ($opts{add}) {
+ # Delete that record
+ testDeleteRecord 'VersionInfo', '2.0';
+} # if
+
+display "done";
--- /dev/null
+#!/usr/bin/perl
+use strict;
+use warnings;
+
+use FindBin;
+
+use lib "$FindBin::Bin/../lib";
+
+use Rexec;
+
+my ($status, $cmd, @output);
+
+my $hostname = $ENV{HOST} || 'localhost';
+my $username = $ENV{USERNAME};
+my $password = $ENV{PASSWORD};
+
+my $remote = Rexec->new (
+ host => $hostname,
+ username => $username,
+ password => $password,
+ timeout => 30,
+);
+
+if ($remote) {
+ print "Connected to $username\@$hostname using "
+ . $remote->{protocol} . " protocol\n";
+
+ $cmd = "/bin/ls /nonexistent";
+
+ @output = $remote->execute ($cmd);
+ $status = $remote->status;
+
+ print "$cmd status: $status\n";
+
+ $remote->print_lines;
+
+ print "$_\n" foreach ($remote->execute ('cat /etc/passwd'));
+} else {
+ print "Unable to connect to $username@$hostname\n";
+} # if
+
+
--- /dev/null
+#!/usr/bin/perl
+use strict;
+use warnings;
+
+=pod
+
+=head1 NAME $RCSfile: testspreadsheet.pl,v $
+
+Test the SpreadSheet libary
+
+This script tests various functions of the SpreadSheet libary
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@ClearSCM.com>
+
+=item Revision
+
+$Revision: 1.1 $
+
+=item Created:
+
+Mon Nov 12 16:50:44 PST 2012
+
+=item Modified:
+
+$Date: 2012/11/21 02:53:28 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage: testclearquest.pl [-u|sage] [-v|erbose] [-d|ebug]
+ -filename <spreadsheet file>
+
+ Where:
+ -usa|ge: Displays usage
+ -v|erbose: Be verbose
+ -de|bug: Output debug messages
+
+ -filename: Spreadsheet file
+
+=cut
+
+use FindBin;
+use Getopt::Long;
+
+use lib "$FindBin::Bin/../lib";
+
+use SpreadSheet;
+use Display;
+use Utils;
+
+sub displayData (@) {
+ my (@rows) = @_;
+
+ my $row = 2;
+
+ foreach (@rows) {
+ my %row = %$_;
+
+ display "Row: $row"; $row++;
+
+ foreach (keys %row) {
+ my $value = $row{$_} || '';
+
+ display "$_: $value";
+ } # foreach
+ } # foreach
+
+ return;
+} # displayRecord
+
+## Main
+local $| = 1;
+
+my %opts;
+
+GetOptions (
+ \%opts,
+ usage => sub { Usage },
+ verbose => sub { set_verbose },
+ debug => sub { set_debug },
+ 'filename=s',
+) || Usage;
+
+Usage "Must specify -filename <filename>" unless $opts{filename};
+
+my $spreadSheet = SpreadSheet->new ($opts{filename});
+
+displayData ($spreadSheet->getSheet);
--- /dev/null
+#!/usr/bin/perl
+use strict;
+use warnings;
+
+use FindBin;
+use Term::ANSIColor qw(:constants);
+
+my $libs;
+
+BEGIN {
+ $libs = $ENV{SITE_PERLLIB} ? $ENV{SITE_PERLLIB} : "$FindBin::Bin/../lib";
+
+ die "Unable to find libraries\n" if !$libs and !-d $libs;
+} # BEGIN
+
+use lib $libs;
+
+use Clearcase;
+use Clearcase::View;
+use Display;
+
+sub DisplayViewInfo ($) {
+ my ($view) = @_;
+
+ display YELLOW . "View:\t\t \t" . RESET . $view->tag;
+ display MAGENTA . "Accessed by:\t\t" . RESET . $view->accessed_by;
+ display MAGENTA . "Accessed date:\t\t" . RESET . $view->accessed_date;
+ display MAGENTA . "Access path:\t\t" . RESET . $view->access_path;
+ display MAGENTA . "Active:\t\t\t" . RESET . $view->active;
+
+ display_nolf MAGENTA . "Additional groups:\t";
+
+ foreach ($view->additional_groups) {
+ display_nolf "$_ ";
+ } # foreach
+
+ display "";
+
+ display MAGENTA . "Created by:\t\t" . RESET . $view->created_by;
+ display MAGENTA . "Created date:\t\t" . RESET . $view->created_date;
+ display MAGENTA . "CS updated by:\t\t" . RESET . $view->cs_updated_by;
+ display MAGENTA . "CS updated date:\t" . RESET . $view->cs_updated_date;
+ display MAGENTA . "Global path:\t\t" . RESET . $view->gpath;
+ display MAGENTA . "Group:\t\t\t" . RESET . $view->group;
+ display MAGENTA . "Group mode:\t\t" . RESET . $view->group_mode;
+ display MAGENTA . "Host:\t\t\t" . RESET . $view->host;
+ display MAGENTA . "Mode:\t\t\t" . RESET . $view->mode;
+ display MAGENTA . "Modified by:\t\t" . RESET . $view->modified_by;
+ display MAGENTA . "Modified date:\t\t" . RESET . $view->modified_date;
+ display MAGENTA . "Other mode:\t\t" . RESET . $view->other_mode;
+ display MAGENTA . "Owner:\t\t\t" . RESET . $view->owner;
+ display MAGENTA . "Owner mode:\t\t" . RESET . $view->owner_mode;
+ display MAGENTA . "Properties:\t\t" . RESET . $view->properties;
+ display MAGENTA . "Region:\t\t\t" . RESET . $view->region;
+ display MAGENTA . "Server host:\t\t" . RESET . $view->shost;
+ display MAGENTA . "Text mode:\t\t" . RESET . $view->text_mode;
+
+ display_nolf MAGENTA . "Type:\t\t\t" . RESET;
+
+ if ($view->snapshot) {
+ display_nolf "snapshot";
+ } else {
+ display_nolf "dynamic";
+ } # if
+
+ if ($view->ucm) {
+ display_nolf ",ucm";
+ } # if
+
+ display "";
+
+ display MAGENTA . "UUID:\t\t\t" . RESET . $view->uuid;
+} # DisplayViewInfo
+
+error "Usage $0 <view tag>", 1 if !$ARGV[0];
+
+foreach (@ARGV) {
+ my $view = new Clearcase::View (tag => $_);
+
+ DisplayViewInfo $view;
+} # foreach
+
--- /dev/null
+#!/usr/bin/perl
+use strict;
+use warnings;
+
+use FindBin;
+use Term::ANSIColor qw(:constants);
+
+my $libs;
+
+BEGIN {
+ $libs = $ENV{SITE_PERLLIB} ? $ENV{SITE_PERLLIB} : "$FindBin::Bin/../lib";
+
+ die "Unable to find libraries\n" if !$libs and !-d $libs;
+} # BEGIN
+
+use lib $libs;
+
+use Clearcase;
+use Clearcase::Views;
+use Display;
+
+my $views = new Clearcase::Views;
+
+my $nbr_views = $views->views;
+my @view_list = $views->views;
+
+display YELLOW . "Clearcase Views\n" . RESET;
+
+display MAGENTA . "Number of views:\t\t" . RESET . $nbr_views;
+display MAGENTA . "View list:\n" . RESET;
+
+display "\t$_" foreach (@view_list);
--- /dev/null
+#!/usr/bin/perl
+use strict;
+use warnings;
+
+use FindBin;
+use Term::ANSIColor qw(:constants);
+
+my $libs;
+
+BEGIN {
+ $libs = $ENV{SITE_PERLLIB} ? $ENV{SITE_PERLLIB} : "$FindBin::Bin/../lib";
+
+ die "Unable to find libraries\n" if !$libs and !-d $libs;
+} # BEGIN
+
+use lib $libs;
+
+use Clearcase;
+use Clearcase::Vobs;
+use Clearcase::Vob;
+use Display;
+
+my $vobs = new Clearcase::Vobs;
+
+my @vob_list = $vobs->vobs;
+
+my $vob;
+my $i = 0;
+
+$vob = new Clearcase::Vob (tag => $vob_list[$i++]);
+
+display YELLOW . "Clearcase VOB\n" . RESET;
+
+display MAGENTA . "Tag:\t\t" . RESET . $vob->tag;
+display MAGENTA . "Global path:\t" . RESET . $vob->gpath;
+display MAGENTA . "Sever host:\t" . RESET . $vob->shost;
+display MAGENTA . "Access:\t\t" . RESET . $vob->access;
+display MAGENTA . "Mount options:\t" . RESET . $vob->mopts;
+display MAGENTA . "Region:\t\t" . RESET . $vob->region;
+display MAGENTA . "Active:\t\t" . RESET . $vob->active;
+display MAGENTA . "Replica UUID:\t" . RESET . $vob->replica_uuid;
+display MAGENTA . "Host:\t\t" . RESET . $vob->host;
+display MAGENTA . "Access path:\t" . RESET . $vob->access_path;
+display MAGENTA . "Family UUID:\t" . RESET . $vob->family_uuid;
+
+display YELLOW . "\nVOB Statistics\n" . RESET;
+display MAGENTA . "Elements:\t" . RESET . $vob->elements;
+display MAGENTA . "Branches:\t" . RESET . $vob->branches;
+display MAGENTA . "Versions:\t" . RESET . $vob->versions;
+display MAGENTA . "DB Size:\t" . RESET . $vob->dbsize;
+display MAGENTA . "Adm Size:\t" . RESET . $vob->admsize;
+display MAGENTA . "CT Size:\t" . RESET . $vob->ctsize;
+display MAGENTA . "DO Size:\t" . RESET . $vob->dbsize;
+display MAGENTA . "Src Size:\t" . RESET . $vob->srcsize;
+display MAGENTA . "Size:\t\t" . RESET . $vob->size;
+
+display YELLOW . "\nVOB manipulation\n" . RESET;
+
+display "Umounting " . $vob->tag . "...";
+
+$vob->umount;
+
+display "Mounting " . $vob->tag . "...";
+
+$vob->mount;
--- /dev/null
+#!/usr/bin/perl
+use strict;
+use warnings;
+
+use FindBin;
+use Term::ANSIColor qw(:constants);
+
+my $libs;
+
+BEGIN {
+ $libs = $ENV{SITE_PERLLIB} ? $ENV{SITE_PERLLIB} : "$FindBin::Bin/../lib";
+
+ die "Unable to find libraries\n" if !$libs and !-d $libs;
+} # BEGIN
+
+use lib $libs;
+
+use Clearcase;
+use Clearcase::Vobs;
+use Display;
+
+my $vobs = new Clearcase::Vobs;
+
+my $nbr_vobs = $vobs->vobs;
+my @vob_list = $vobs->vobs;
+
+display YELLOW . "Clearcase VOBs\n" . RESET;
+
+display MAGENTA . "Number of vobs:\t\t" . RESET . $nbr_vobs;
+display MAGENTA . "VOB list:\n" . RESET;
+
+display "\t$_" foreach (@vob_list);
+
+if ($vobs->umount) {
+ display "Unmounted all vobs";
+} # if
+
+if ($vobs->mount) {
+ display "Mounted all vobs";
+} # if
--- /dev/null
+php_value include_path /usr/local/psa/home/vhosts/clearscm.com/httpdocs/php
--- /dev/null
+function imenus_data0 () {\r
+ this.menu_showhide_delay = 150;\r
+ this.show_subs_onclick = false;\r
+ this.hide_focus_box = false;\r
+\r
+ // Box Animation Settings\r
+ this.box_animation_type = "center";\r
+ this.box_animation_frames = 15;\r
+ this.box_animation_styles = "border-style:solid; border-color:#999999; border-width:1px;";\r
+\r
+ // Animated Pointer Icon Settings\r
+ this.main_pointer_image = "/Icons/arrow_down.gif";\r
+ this.main_pointer_image_width = "10";\r
+ this.main_pointer_image_height = "11";\r
+ this.main_pointer_image_offx = "-3";\r
+ this.main_pointer_image_offy = "-14";\r
+\r
+ this.sub_pointer_image = "/Icons/arrow_right.gif";\r
+ this.sub_pointer_image_width = "13";\r
+ this.sub_pointer_image_height = "10";\r
+ this.sub_pointer_image_offx = "-13";\r
+ this.sub_pointer_image_offy = "-5";\r
+\r
+ // IE Transition Effects\r
+ this.subs_ie_transition_show = "";\r
+} // imenus_data0\r
+\r
+ulm_last_pointer = null;\r
+\r
+function imenus_add_pointer_image (obj,dto,level) {\r
+ if (ulm_oldnav || (ulm_mac && (ulm_ie||ulm_navigator))) {\r
+ return;\r
+ } // if\r
+\r
+ x4 = "main";\r
+ \r
+ if (level > 0) {\r
+ x4 = "sub";\r
+ } // if\r
+\r
+ var c_horizontal = true;\r
+\r
+ if (level == 0) {\r
+ if ((ob1 = obj.getElementsByTagName ("LI") [0]) &&\r
+ (ob1.style.width.indexOf ("100%") + 1)) {\r
+ c_horizontal=false;\r
+ } // if\r
+ } // if\r
+\r
+ var a = obj.parentNode.getElementsByTagName ("UL") [0];\r
+ var id = a.id.substring (a.id.indexOf ("_") + 1);\r
+\r
+ x3 = document.createElement ("DIV");\r
+ x3.id = "pi" + a.id;\r
+ x3.style.position = "absolute";\r
+ x3.style.visibility = "hidden";\r
+ x3.style.fontSize = "0px";\r
+ x3.style.lineHeight = "0px";\r
+ x3.style.zIndex = 999;\r
+\r
+ x3.setAttribute ("ispointer", 1);\r
+ x3.setAttribute ("scxy", "0,0");\r
+ x3.setAttribute ("offxy", "0,0");\r
+\r
+ if ((level == 0) && (c_horizontal)) {\r
+ x3.setAttribute ("ish", 1);\r
+ x3.setAttribute ("fxoff", x25 (dto.main_pointer_image_offy));\r
+ x3.setAttribute ("sloff", x25 (dto.main_pointer_image_offx));\r
+ } else {\r
+ x3.setAttribute ("fxoff", x25 (x27_pointer (x4 + "_pointer_image_offx", dto, id)));\r
+ x3.setAttribute ("sloff", x25 (x27_pointer (x4 + "_pointer_image_offy", dto, id)));\r
+ } // if\r
+ \r
+ wht = "";\r
+\r
+ if ((tval = x27_pointer (x4 + "_pointer_image_width", dto, id))) {\r
+ wht += "width='" + tval + "'";\r
+ } // if\r
+\r
+ if ((tval = x27_pointer (x4 + "_pointer_image_height", dto, id))) {\r
+ wht += "height='" + tval + "'";\r
+ } // if\r
+\r
+ x5 = x27_pointer (x4 + "_pointer_image", dto, id);\r
+\r
+ if (!x5 || x5.toLowerCase () == "none") {\r
+ obj.setAttribute ("noimage", 1);\r
+ } else {\r
+ obj.removeAttribute ("noimage");\r
+ } // if\r
+\r
+ var dexist = false;\r
+ var dobj = obj.childNodes;\r
+\r
+ for (var d=0; d<dobj.length; d++) {\r
+ if (dobj [d].getAttribute && dobj [d].getAttribute ("ispointer")) {\r
+ dexist=true;\r
+ } // if\r
+ } // for\r
+ \r
+ if (!dexist) {\r
+ x3.innerHTML = '<img src="' + x5 + '" ' + wht + '>';\r
+ obj.appendChild (x3);\r
+ } // if\r
+ \r
+ obj.onmousemove = function (e) {\r
+ e = e || window.event;\r
+\r
+ var x32 = this;\r
+\r
+ if (this.tagName == "DIV") {\r
+ x32 = this.getElementsByTagName ("UL") [0];\r
+ } // if\r
+\r
+ if ((x32.className.indexOf ("imncc") + 1) ||\r
+ (x32.parentNode.className.indexOf ("imncc") + 1) ||\r
+ this.getAttribute("noimage")) {\r
+ imenus_hide_pointer();\r
+\r
+ if (!x32.id || x32.id.indexOf ("imenus") == -1) {\r
+ im_kille (e);\r
+ } // if\r
+\r
+ return false;\r
+\r
+ } // if\r
+ \r
+ var lc = this.lastChild;\r
+ var bid;\r
+\r
+ if (!lc.getAttribute ("ispointer")) {\r
+ bid = this.getElementsByTagName ("UL") [0].id;\r
+ lc = document.getElementById ("pi"+bid);\r
+ } // if\r
+\r
+ if (!lc.getAttribute ("initialized")) {\r
+ imenus_initialize_pointer (this,lc);\r
+ } // if\r
+\r
+ offxy = eval ("new Array(" + lc.getAttribute ("offxy") + ")");\r
+ sloff = parseInt (lc.getAttribute ("sloff"));\r
+ scxy = eval ("new Array(" + lc.getAttribute ("scxy") + ")");\r
+\r
+ if (lc.getAttribute ("ish")) {\r
+ npos = e.clientX - offxy [0] + sloff + scxy [0];\r
+\r
+ if (window.dp_zoomc) {\r
+ npos=dp_zoomc(npos);\r
+ } // if\r
+\r
+ setTimeout ("imenus_pointer_move('" + lc.id + "'," + npos + ",'h')", 0);\r
+ } else {\r
+ npos = e.clientY - offxy [1] + sloff + scxy [1];\r
+\r
+ if (window.dp_zoomc) {\r
+ npos=dp_zoomc(npos);\r
+ } // if\r
+\r
+ setTimeout ("imenus_pointer_move('" + lc.id + "'," + npos + ")", 0);\r
+ } // if\r
+\r
+ var a;\r
+\r
+ if (a = window.imenus_event_mc_onmousemove) {\r
+ a ();\r
+ } // if\r
+\r
+ im_kille (e);\r
+\r
+ return false;\r
+ };\r
+} // imenus_add_pointer_image\r
+\r
+function imenus_pointer_move (id,npos,type) {\r
+ var md = document.getElementById (id);\r
+\r
+ if(type == "h") {\r
+ md.style.left = npos + "px";\r
+ } else {\r
+ md.style.top = npos + "px";\r
+ } // if\r
+\r
+ if (md.getAttribute ("initialized")) {\r
+ md.style.visibility = "inherit";\r
+ } // if\r
+} // imenus_pointer_move\r
+\r
+function x25 (val) {\r
+ if (val == null) {\r
+ return 0;\r
+ } else {\r
+ return val;\r
+ } // if\r
+} // x26\r
+\r
+function imenus_hide_pointer (check) {\r
+ if (ulm_last_pointer && ulm_last_pointer.parentNode != check) {\r
+ ulm_last_pointer.style.visibility = "hidden";\r
+ ulm_last_pointer.removeAttribute("initialized");\r
+ } // if\r
+} imenus_hide_pointer\r
+\r
+function imenus_initialize_pointer (obj, lc) {\r
+ imenus_hide_pointer ();\r
+\r
+ ulm_last_pointer = lc;\r
+\r
+ var txy = x26 (obj);\r
+\r
+ if (hpi = document.getElementById ("hpi_pad")) {\r
+ if (a = hpi.scrollLeft) {\r
+ txy [0] -= a;\r
+ } // if\r
+\r
+ if (a = hpi.scrollTop) {\r
+ txy [1] -=a;\r
+ } // if\r
+ } // if\r
+\r
+ lc.setAttribute ("offxy", txy);\r
+\r
+ var pxy = parseInt (lc.getAttribute ("fxoff"));\r
+\r
+ if (lc.getAttribute ("ish")) {\r
+ lc.style.top = pxy + "px";\r
+ } else {\r
+ lc.style.left = pxy + "px";\r
+ } // if\r
+\r
+ pobj = document.body;\r
+\r
+ if ((!(pobj.scrollLeft+pobj.scrollTop)) &&\r
+ (document.documentElement)) {\r
+ pobj=document.documentElement;\r
+ } // if\r
+\r
+ lc.setAttribute ("scxy", pobj.scrollLeft + "," + pobj.scrollTop);\r
+ lc.setAttribute ("initialized", 1);\r
+} // imenus_initialize_pointer\r
+\r
+function x27_pointer (pname, dto, index) {\r
+ if ((rval = dto [pname + index]) != null) {\r
+ return rval;\r
+ } else {\r
+ return dto [pname];\r
+ } // if\r
+} // x27_pointer\r
+\r
+function imenus_box_ani_init (obj, dto) {\r
+ var tid = obj.getElementsByTagName ("UL") [0].id.substring (6);\r
+\r
+ if (!(ulm_navigator && ulm_mac) &&\r
+ !(window.opera && ulm_mac) &&\r
+ !(window.navigator.userAgent.indexOf("afari")+1) &&\r
+ !ulm_iemac&&dto.box_animation_frames > 0 &&\r
+ !dto.box_animation_disabled) {\r
+ ulm_boxa ["go" + tid] = true;\r
+ ulm_boxa.go = true;\r
+ ulm_boxa.all = new Object ();\r
+ }else {\r
+ return;\r
+ } // if\r
+} // imenus_box_ani_init\r
+\r
+function imenus_box_ani (show, tul, hobj, e) {\r
+ if (tul.className.indexOf ("imcanvassubc") + 1) {\r
+ hover_handle (hobj);\r
+ return;\r
+ } //\r
+\r
+ if (!ulm_boxa.cm) {\r
+ ulm_boxa.cm = new Object ();\r
+ } // if\r
+\r
+ if (!ulm_boxa ["ba" + hobj.id]) {\r
+ ulm_boxa ["ba" + hobj.id] = new Object ();\r
+ } // if\r
+\r
+ ulm_boxa ["ba" + hobj.id].hobj = hobj;\r
+\r
+ var bo = ulm_boxa ["ba" + hobj.id];\r
+\r
+ bo.id = "ba" + hobj.id;\r
+\r
+ if (!bo.bdiv) {\r
+ bdiv = document.createElement ("DIV");\r
+ bdiv.className = "ulmba";\r
+ bdiv.onmousemove = function (e) {\r
+ if (!e) {\r
+ e=event;\r
+ } // if\r
+\r
+ e.cancelBubble = true;\r
+ };\r
+ bdiv.onmouseover = function (e) {\r
+ if (!e) {\r
+ e = event;\r
+ } // if\r
+ e.cancelBubble = true;\r
+ };\r
+ bdiv.onmouseout = function (e) {\r
+ if (!e) {\r
+ e=event;\r
+ } // if\r
+\r
+ e.cancelBubble = true;\r
+ };\r
+ bo.bdiv = tul.parentNode.appendChild (bdiv);\r
+ } // if\r
+\r
+ var i;\r
+\r
+ for (i in ulm_boxa) {\r
+ if ((ulm_boxa [i].steps) && !(ulm_boxa [i].id.indexOf (hobj.id) + 1)) {\r
+ ulm_boxa [i].reverse = true;\r
+ } // if\r
+ } // for\r
+\r
+ if (((hobj.className.indexOf ("ishow") + 1) && bo.hobj) ||\r
+ (bo.bdiv.style.visibility == "visible" && !bo.reverse)) {\r
+ return true;\r
+ } // if\r
+\r
+ imenus_box_show (bo, hobj, tul, e);\r
+} // imenus_box_ani\r
+\r
+function imenus_box_h (hobj) {\r
+ if (hobj.className.indexOf ("imctitleli") + 1) {\r
+ return;\r
+ } // if\r
+\r
+ var bo = ulm_boxa ["ba" + hobj.id];\r
+\r
+ if (bo && bo.bdiv && bo.pos) {\r
+ bo.reverse = true;\r
+ bo.pos = bo.steps;\r
+ bo.bdiv.style.visibility = "visible";\r
+ imenus_box_x44 (bo);\r
+ } // if\r
+} // imenus_box_x44\r
+\r
+function imenus_box_reverse (x17) {\r
+ if (!ulm_boxa.go) {\r
+ return;\r
+ } // if\r
+\r
+ var i;\r
+\r
+ for (i in ulm_boxa.all) {\r
+ if (ulm_boxa.all [i] && ulm_boxa [i].hobj != x17) {\r
+ var bo = ulm_boxa [i];\r
+\r
+ bo.reverse = true;\r
+ ulm_boxa.all [i] = null;\r
+ } // if\r
+ } // for\r
+} // imenus_box_reverse\r
+\r
+function imenus_box_show (bo, hobj, tul, e) {\r
+ var type;\r
+ var tdto = ulm_boxa ["dto" + parseInt (hobj.id.substring (6))];\r
+\r
+ clearTimeout (bo.st);\r
+\r
+ bo.st = null;\r
+\r
+ if (bo.bdiv) {\r
+ bo.bdiv.style.visibility = "hidden";\r
+ } // if\r
+\r
+ bo.pos = 0;\r
+ bo.reverse = false;\r
+ bo.steps = tdto.box_animation_frames;\r
+ bo.exy = new Array (tul.offsetLeft, tul.offsetTop);\r
+ bo.ewh = new Array (tul.offsetWidth, tul.offsetHeight);\r
+ bo.sxy = new Array (0, 0);\r
+\r
+ if (!(type = tul.getAttribute ("boxatype"))) {\r
+ type = tdto.box_animation_type;\r
+ } // if\r
+\r
+ if (type == "center") {\r
+ bo.sxy = new Array (bo.exy [0] + parseInt (bo.ewh [0] / 2), \r
+ bo.exy [1] + parseInt (bo.ewh [1] / 2));\r
+ } else if (type == "top") {\r
+ bo.sxy = new Array (parseInt (bo.ewh [0] / 2), 0);\r
+ } else if (type == "left") {\r
+ bo.sxy = new Array (0, parseInt (bo.ewh [1] / 2));\r
+ } else if (type=="pointer") {\r
+ if (!e) {\r
+ e = window.event;\r
+ } // if\r
+\r
+ var txy = x26 (tul);\r
+\r
+ bo.sxy = new Array (e.clientX - txy [0], (e.clientY - txy [1]) + 5);\r
+ } // if\r
+\r
+ bo.dxy = new Array (bo.exy [0] - bo.sxy [0], bo.exy [1] - bo.sxy [1]);\r
+ bo.dwh = new Array (bo.ewh [0], bo.ewh [1]);\r
+ bo.tul = tul;\r
+ bo.hobj = hobj;\r
+\r
+ imenus_box_x44(bo);\r
+} // imenus_box_show\r
+\r
+function imenus_box_x44 (bo) {\r
+ var a = bo.bdiv;\r
+ var cx = bo.sxy [0] + parseInt ((bo.dxy [0] / bo.steps) * bo.pos);\r
+ var cy = bo.sxy [1] + parseInt ((bo.dxy [1] / bo.steps) * bo.pos);\r
+\r
+ a.style.left = cx + "px";\r
+ a.style.top = cy + "px";\r
+\r
+ var cw = parseInt ((bo.dwh [0] / bo.steps) * bo.pos);\r
+ var ch = parseInt ((bo.dwh [1] / bo.steps) * bo.pos);\r
+\r
+ a.style.width = cw + "px";\r
+ a.style.height = ch + "px";\r
+\r
+ if (bo.pos <= bo.steps) {\r
+ if (bo.pos == 0) {\r
+ a.style.visibility="visible";\r
+ } // if\r
+\r
+ if (bo.reverse == true) {\r
+ bo.pos--;\r
+ } else {\r
+ bo.pos++;\r
+ } // if\r
+\r
+ if (bo.pos == -1) {\r
+ bo.pos = 0;\r
+ a.style.visibility = "hidden";\r
+ } else {\r
+ bo.st = setTimeout ("imenus_box_x44(ulm_boxa['" + bo.id + "'])", 8);\r
+ ulm_boxa.all[bo.id]=true;\r
+ } // if\r
+ } else {\r
+ clearTimeout (bo.st);\r
+\r
+ bo.st = null;\r
+ ulm_boxa.all [bo.id] = null;\r
+\r
+ if (!bo.reverse) {\r
+ if ((bo.hobj) && (bo.pos > -1)) {\r
+ hover_handle (bo.hobj);\r
+ } // if\r
+ }\r
+\r
+ a.style.visibility = "hidden";\r
+ } // if\r
+} // imenus_box_x44\r
+\r
+function iao_iframefix () {\r
+ if (ulm_ie && !ulm_mac && !ulm_oldie && !ulm_ie7) {\r
+ for (var i = 0;i < (x31 = uld.getElementsByTagName ("iframe")).length; i++) {\r
+ if ((a = x31 [i]).getAttribute ("x30")) {\r
+ a.style.height = (x32 = a.parentNode.getElementsByTagName ("UL") [0]).offsetHeight;\r
+ a.style.width = x32.offsetWidth;\r
+ } // if\r
+ } // for\r
+ } // if\r
+} // iao_iframefix\r
+\r
+function iao_ifix_add (b) {\r
+ if (ulm_ie &&\r
+ !ulm_mac &&\r
+ !ulm_oldie &&\r
+ !ulm_ie7 &&\r
+ window.name != "hta" &&\r
+ window.name != "imopenmenu") {\r
+ b.parentNode.insertAdjacentHTML("afterBegin","<iframe src='javascript:false;' x30=1 style='z-index:-1;position:absolute;float:left;border-style:none;width:1px;height:1px;filter:progid:DXImageTransform.Microsoft.Alpha(Opacity=0);' frameborder='0'></iframe><div></div>");\r
+ } // if\r
+} // iao_ifix_add\r
+\r
+// ---- IM Code + Security [7.5 KB] ----\r
+im_version = "10.x";\r
+ht_obj = new Object ();\r
+cm_obj = new Object ();\r
+uld = document;\r
+ule = "position:absolute;";\r
+ulf = "visibility:visible;";\r
+ulm_boxa = new Object ();\r
+\r
+var ulm_d;\r
+\r
+ulm_mglobal = new Object ();\r
+ulm_rss = new Object();\r
+nua = navigator.userAgent;\r
+ulm_ie = window.showHelp;\r
+ulm_ie7 = nua.indexOf ("MSIE 7") + 1;\r
+ulm_mac = nua.indexOf ("Mac") + 1;\r
+ulm_navigator = nua.indexOf ("Netscape") + 1;\r
+ulm_version = parseFloat (navigator.vendorSub);\r
+ulm_oldnav = ulm_navigator && ulm_version < 7.1;\r
+ulm_oldie = ulm_ie && nua.indexOf("MSIE 5.0") + 1;\r
+ulm_iemac = ulm_ie && ulm_mac;\r
+ulm_opera = nua.indexOf ("Opera") + 1;\r
+ulm_safari = nua.indexOf ("afari") + 1;\r
+x42 = "_";\r
+ulm_curs = "cursor:hand;";\r
+\r
+if (!ulm_ie) {\r
+ x42 = "z";\r
+ ulm_curs = "cursor:pointer;";\r
+} // if\r
+\r
+ulmpi = window.imenus_add_pointer_image;\r
+\r
+var x43;\r
+\r
+for (mi = 0; mi < (x1 = uld.getElementsByTagName ("UL")).length; mi++) {\r
+ if ((x2 = x1 [mi].id) && x2.indexOf ("imenus") + 1) {\r
+ dto = new window ["imenus_data" + (x2 = x2.substring (6))];\r
+ ulm_boxa.dto=dto;\r
+ ulm_boxa["dto"+x2]=dto;\r
+ ulm_d=dto.menu_showhide_delay;\r
+\r
+ if (ulm_ie && !ulm_ie7 && !ulm_mac && (b = window.imenus_efix)) {\r
+ b (x2);\r
+ } // if\r
+\r
+ imenus_create_menu (x1 [mi].childNodes, x2 + x42, dto, x2);\r
+ (ap1 = x1 [mi].parentNode).id = "imouter" + x2;\r
+ ulm_mglobal ["imde" + x2] = ap1;\r
+\r
+ var dt = "onmouseover";\r
+\r
+ if (ulm_mglobal.activate_onclick) {\r
+ dt = "onclick";\r
+ } // if\r
+\r
+ document [dt] = function () {\r
+ var a;\r
+\r
+ if (!ht_obj.doc) {\r
+ clearTimeout (ht_obj.doc);\r
+\r
+ ht_obj.doc = null;\r
+ } else {\r
+ return;\r
+ } // if\r
+\r
+ ht_obj.doc = setTimeout ("im_hide()", ulm_d);\r
+\r
+ if (a = window.imenus_box_reverse) {\r
+ a ();\r
+ } // if\r
+\r
+ if (a = window.imenus_expandani_hideall) {\r
+ a ();\r
+ } // if\r
+\r
+ if (a = window.imenus_hide_pointer) {\r
+ a ();\r
+ } // if\r
+\r
+ if (a = window.imenus_shift_hide_all) {\r
+ a ();\r
+ } // if\r
+ };\r
+\r
+ imarc ("imde", ap1);\r
+\r
+ if (ulm_oldnav) {\r
+ ap1.parentNode.style.position="static";\r
+ } // if\r
+\r
+ if (!ulm_oldnav&&ulmpi) {\r
+ ulmpi (x1 [mi], dto, 0, x2);\r
+ } // if\r
+\r
+ x6 (x2, dto);\r
+\r
+ if ((ulm_ie && !ulm_iemac) && (b1 = window.iao_iframefix)) {\r
+ window.attachEvent ("onload", b1);\r
+ } // if\r
+\r
+ if (b1 = window.imenus_box_ani_init) {\r
+ b1 (ap1, dto);\r
+ } // if\r
+\r
+ if (b1 = window.imenus_expandani_init) {\r
+ b1 (ap1, dto);\r
+ } // if\r
+\r
+ if (b1 = window.imenus_info_addmsg) {\r
+ b1 (x2, dto);\r
+ } // if\r
+\r
+ if (b1 = window.im_conexp_init) {\r
+ b1 (dto, ap1, x2);\r
+ } // if\r
+ } // if\r
+} // for\r
+\r
+function imenus_create_menu (nodes, prefix, dto, d_toid, sid, level) {\r
+ var counter = 0;\r
+\r
+ if (sid) {\r
+ counter=sid;\r
+ } // sid\r
+\r
+ for (var li = 0; li < nodes.length; li++) {\r
+ var a = nodes [li];\r
+ var c;\r
+\r
+ if (a.tagName == "LI") {\r
+ a.id = "ulitem" + prefix + counter;\r
+\r
+ (this.atag = a.getElementsByTagName ("A") [0]).id = "ulaitem" + prefix + counter;\r
+\r
+ if (c = this.atag.getAttribute ("himg")) {\r
+ ulm_mglobal ["timg" + a.id] = new Image ();\r
+ ulm_mglobal ["timg" + a.id].src = c;\r
+ } // if\r
+\r
+ var level;\r
+\r
+ a.level = (level = prefix.split (x42).length - 1);\r
+ a.dto = d_toid;\r
+ a.x4 = prefix;\r
+ a.sid = counter;\r
+\r
+ if ((a1 = window.imenus_drag_evts) && level > 1) {\r
+ a1 (a, dto);\r
+ } // if\r
+\r
+ a.onkeydown = function (e) {\r
+ e = e || window.event;\r
+ \r
+ if (e.keyCode == 13 && !ulm_boxa.go) {\r
+ hover_handle (this,1);\r
+ } // if\r
+ };\r
+\r
+ if (dto.hide_focus_box) {\r
+ this.atag.onfocus = function () {\r
+ this.blur ()\r
+ };\r
+ } // if\r
+\r
+ imenus_se (a,dto);\r
+\r
+ this.isb = false;\r
+ x29 =a .getElementsByTagName ("UL");\r
+\r
+ for (ti = 0; ti < x29.length; ti++) {\r
+ var b = x29 [ti];\r
+\r
+ if (c = window.iao_ifix_add) {\r
+ c (b);\r
+ } // if\r
+\r
+ var wgc;\r
+\r
+ if (wgc = window.getComputedStyle) {\r
+ if (wgc (b.parentNode, "").getPropertyValue ("visibility") == "visible") {\r
+ cm_obj [a.id] = a;\r
+\r
+ imarc ("ishow", a, 1);\r
+ } // if\r
+ } else if (ulm_ie && b.parentNode.currentStyle.visibility == "visible") {\r
+ cm_obj [a.id] = a;\r
+\r
+ imarc ("ishow", a, 1);\r
+ } // if\r
+\r
+ if ((dd = this.atag.firstChild) &&\r
+ (dd.tagName == "SPAN") &&\r
+ (dd.className.indexOf ("imea") + 1)) {\r
+ this.isb=true;\r
+\r
+ if (ulm_mglobal.eimg_fix) {\r
+ imenus_efix_add (level,dd);\r
+ } // if\r
+\r
+ dd.className = dd.className + "j";\r
+ dd.firstChild.id = "ea" + a.id;\r
+\r
+ dd.setAttribute ("imexpandarrow", 1);\r
+ } // if\r
+\r
+ b.id = "x1ub" + prefix + counter;\r
+\r
+ if (!ulm_oldnav && ulmpi) {\r
+ ulmpi (b.parentNode, dto, level);\r
+ } // if\r
+\r
+ new imenus_create_menu (b.childNodes, prefix + counter + x42, dto, d_toid);\r
+ } // for\r
+\r
+ if ((a1 = window.imenus_button_add) && level == 1) {\r
+ a1 (this.atag, dto);\r
+ } // if\r
+\r
+ if (this.isb && ulm_ie && level == 1 && document.getElementById ("ssimaw")) {\r
+ if (a1 = window.imenus_autowidth) {\r
+ a1(this.atag,counter);\r
+ } // if\r
+ } // if\r
+\r
+ if (!sid &&\r
+ !ulm_navigator &&\r
+ !ulm_iemac &&\r
+ (rssurl = a.getAttribute ("rssfeed")) &&\r
+ (c=window.imenus_get_rss_data)) {\r
+ c (a,rssurl);\r
+ } // if\r
+\r
+ counter++;\r
+ } // if\r
+ } // for\r
+} //imenus_create_menu\r
+\r
+function imenus_se (a, dto) {\r
+ var d;\r
+\r
+ if (!(d = window.imenus_onclick_events) ||\r
+ !d (a, dto)) {\r
+ a.onmouseover = function (e) {\r
+ var a, b, at;\r
+\r
+ clearTimeout (ht_obj.doc);\r
+\r
+ ht_obj.doc = null;\r
+\r
+ if (((at = this.getElementsByTagName ("A") [0]).className.indexOf ("iactive") == -1) &&\r
+ at.className.indexOf ("imsubtitle") == -1) {\r
+ imarc ("ihover", at, 1);\r
+ } // if\r
+\r
+ if (b = at.getAttribute ("himg")) {\r
+ if (!at.getAttribute ("zhimg")) {\r
+ at.setAttribute ("zhimg", at.style.backgroundImage);\r
+ } // if\r
+\r
+ at.style.backgroundImage = "url(" + b + ")";\r
+ } // if\r
+\r
+ if (b = window.imenus_shift) {\r
+ b (at);\r
+ } // if\r
+\r
+ if (b = window.imenus_expandani_animateit) {\r
+ b (this);\r
+ } // if\r
+\r
+ if ((ulm_boxa ["go" + parseInt (this.id.substring (6))]) &&\r
+ (a = this.getElementsByTagName ("UL") [0])) {\r
+ imenus_box_ani (true, a, this, e);\r
+ } else {\r
+ if (this.className.indexOf ("ishow") == -1) {\r
+ ht_obj [this.level] = setTimeout ("hover_handle(uld.getElementById('" + this.id + "'))", ulm_d);\r
+ } // if\r
+\r
+ if (a = window.imenus_box_reverse) {\r
+ a (this);\r
+ } // if\r
+ } // if\r
+\r
+ if (a = window.im_conexp_show) {\r
+ a(this);\r
+ } // if\r
+\r
+ if (!window.imenus_chover) {\r
+ im_kille (e);\r
+ return false;\r
+ } // if\r
+ };\r
+\r
+ a.onmouseout = function (e) {\r
+ var a, b;\r
+\r
+ if((a = this.getElementsByTagName ("A") [0]).className.indexOf ("iactive") == -1) {\r
+ imarc ("ihover", a);\r
+ imarc ("iactive", a);\r
+ } // if\r
+\r
+ if (this.className.indexOf ("ishow") == -1 && (b = a.getAttribute ("zhimg"))) {\r
+ a.style.backgroundImage = b;\r
+ } // if\r
+\r
+ clearTimeout (ht_obj [this.level]);\r
+\r
+ if (!window.imenus_chover) {\r
+ im_kille (e);\r
+ return false;\r
+ } // if\r
+ };\r
+ } //\r
+} // imenus_se\r
+\r
+function im_hide (hobj) {\r
+ for (i in cm_obj) {\r
+ var tco = cm_obj [i];\r
+ var b;\r
+ \r
+ if (tco) { \r
+ if (hobj && hobj.id.indexOf (tco.id) + 1) {\r
+ continue;\r
+ } // if\r
+\r
+ imarc ("ishow", tco);\r
+\r
+ var at = tco.getElementsByTagName ("A") [0];\r
+\r
+ imarc ("ihover", at);\r
+ imarc ("iactive", at);\r
+\r
+ if (b = at.getAttribute ("zhimg")) {\r
+ at.style.backgroundImage = b;\r
+ } // if\r
+\r
+ cm_obj [i] = null;\r
+ i++;\r
+\r
+ if (ulm_boxa ["go" + parseInt (tco.id.substring (6))]) {\r
+ imenus_box_h (tco);\r
+ } // if\r
+\r
+ var a;\r
+\r
+ if (a = window.imenus_expandani_hideit) {\r
+ a (tco);\r
+ } // if\r
+\r
+ if (a = window.imenus_shift_hide) {\r
+ a (at);\r
+ } // if\r
+ } // if\r
+ } // for\r
+} // im_hide\r
+\r
+function hover_handle (hobj) {\r
+ im_hide (hobj);\r
+\r
+ var tul;\r
+\r
+ if (tul = hobj.getElementsByTagName ("UL") [0]) {\r
+ try {\r
+ if ((ulm_ie && !ulm_mac) &&\r
+ (plobj = tul.filters [0]) &&\r
+ tul.parentNode.currentStyle.visibility=="hidden") {\r
+ if (x43) {\r
+ x43.stop ();\r
+ } // if\r
+\r
+ plobj.apply ();\r
+ plobj.play ();\r
+\r
+ x43 = plobj;\r
+ } // if\r
+ } catch (e) {\r
+ }\r
+\r
+ var a;\r
+\r
+ if(a = window.imenus_stack_init) {\r
+ a (tul);\r
+ } // if\r
+\r
+ if (a = window.iao_apos) {\r
+ a (tul);\r
+ } // if\r
+\r
+ var at = hobj.getElementsByTagName ("A") [0];\r
+\r
+ imarc ("ihover", at, 1);\r
+ imarc ("iactive", at, 1);\r
+ imarc ("ishow", hobj, 1);\r
+\r
+ cm_obj [hobj.id] = hobj;\r
+\r
+ if (a = window.imenus_stack_ani) {\r
+ a (tul);\r
+ } // if\r
+ } // if\r
+} // hover_handle\r
+\r
+function imarc (name, obj, add) { \r
+ if (add) {\r
+ if (obj.className.indexOf (name) == -1) {\r
+ obj.className += (obj.className ? ' ' : '') + name;\r
+ } // if\r
+ } else {\r
+ obj.className = obj.className.replace (" " + name, "");\r
+ obj.className = obj.className.replace (name, "");\r
+ } // if\r
+} // imarc\r
+\r
+function x26 (obj) {\r
+ var x = 0;\r
+ var y = 0;\r
+\r
+ do {\r
+ x += obj.offsetLeft;\r
+ y += obj.offsetTop;\r
+ } while (obj = obj.offsetParent) {\r
+ return new Array (x,y);\r
+ } // while\r
+} // x26\r
+\r
+function im_kille (e) {\r
+ if (!e) {\r
+ e=event;\r
+ } // if\r
+\r
+ e.cancelBubble = true;\r
+\r
+ if (e.stopPropagation) {\r
+ e.stopPropagation ();\r
+ } // if\r
+} // im_kille\r
+\r
+function x6 (id,dto) {\r
+ x18 = "#imenus" + id;\r
+ sd = "<style type='text/css'>";\r
+ ubt = "";\r
+ lbt = "";\r
+ x22 = "";\r
+ x23 = "";\r
+\r
+ for (hi = 1; hi < 6; hi++) {\r
+ ubt += "li ";\r
+ lbt += " li";\r
+ x22 += x18 + " li.ishow " + ubt + " .imsubc";\r
+ x23 += x18 + lbt + ".ishow .imsubc";\r
+\r
+ if (hi != 5) {\r
+ x22 += ",";\r
+ x23 += ",";\r
+ } // if\r
+ } // for\r
+\r
+ sd += x22 + "{visibility:hidden;}";\r
+ sd += x23 + "{" + ulf + "}";\r
+ sd += x18 + " li ul{" + ((!window.imenus_drag_evts && window.name != "hta" && ulm_ie) ?\r
+ dto.subs_ie_transition_show : "") + "}";\r
+\r
+ if (ulm_oldnav) {\r
+ sd += ".imcm .imsc{position:absolute;}";\r
+ } // if\r
+\r
+ if (ulm_ie && !((dcm = document.compatMode) && dcm == "CSS1Compat")) {\r
+ sd+=".imgl .imbrc{height:1px;}";\r
+ } // if\r
+\r
+ if (a1 = window.imenus_drag_styles) {\r
+ sd += a1 (id, dto);\r
+ } // if\r
+\r
+ if (a1 = window.imenus_info_styles) {\r
+ sd += a1 (id, dto);\r
+ } // if\r
+\r
+ if (ulm_mglobal.eimg_fix) {\r
+ sd += imenus_efix_styles (x18);\r
+ } // if\r
+\r
+ sd += "</style>";\r
+ sd += "<style id='extimenus"+id+"' type='text/css'>";sd+=x18+" .ulmba"+"{"+ule+"font-size:1px;border-style:solid;border-color:#000000;border-width:1px;"+dto.box_animation_styles+"}";\r
+ sd += "</style>";\r
+\r
+ uld.write (sd);\r
+} // x6\r
+\r
--- /dev/null
+////////////////////////////////////////////////////////////////////////////////
+//
+// File: common.js
+// Description: Common Javascript functions
+// Author: Andrew@DeFaria.com
+// Created: Thu Oct 6 14:16:05 PDT 2011
+// Language: javascript
+//
+////////////////////////////////////////////////////////////////////////////////
+function basename (path) {
+ return path.replace (/\\/g, '/').replace (/.*\//, '');
+} // basename
+
+function dirname (path) {
+ return path.replace (/\\/g, '/').replace (/\/[^\/]*$/, '');
+} // dirname
+
+function getText (item) {
+ // There's this annoying thing about getting the text of an HTML object - both
+ // Chrome and IE use innerText but Firefox uses textContent.
+ return item.innerText ? item.innerText : item.textContent;
+} // getText
+
+function getVar (variable) {
+ var query = window.location.search.substring (1);
+
+ var vars = query.split ('&');
+
+ for (var i=0; i < vars.length; i++) {
+ var pair = vars[i].split ('=');
+
+ if (pair[0] == variable) {
+ return pair[1];
+ } // if
+ } // for
+
+ return null;
+} // getVar
+
+function keys (obj) {
+ // keys: Emulate Perl's keys function. Note that hashes in Javascript are
+ // implemented as associative arrays, which are really objects. There is no
+ // keys function and as an Objects there are functions in there. So we use the
+ // hasOwnProperty function to insure that this is a pproperty and not a
+ // method.
+ var keys = [];
+
+ for (key in obj) {
+ if (obj.hasOwnProperty (key)) keys.push (key);
+ } // for
+
+ return keys;
+} // keys
+
+function objLength (object) {
+ // The .length property doesn't exist for JavaScript objects and associative
+ // arrays. You need to count the properties instead.
+ var count = 0;
+
+ for (property in object) {
+ if (object.hasOwnProperty (property)) {
+ count++;
+ } // if
+ } // for
+
+ return count;
+} // objLength
\ No newline at end of file
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+ <title>ClearSCM: Our People: Andrew DeFaria - President</title>
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Article.css">
+ <link rel="stylesheet" type="text/css" media="print" href="/css/Print.css">
+ <link rel="SHORTCUT ICON" href="http://clearscm.com/favicon.ico" type="image/png">
+
+<script type="text/javascript">
+function blink () {
+ if (!document.getElementById('blink').style.color) {
+ document.getElementById('blink').style.color="white";
+ } // if
+
+ if (document.getElementById('blink').style.color=="white") {
+ document.getElementById('blink').style.color="red";
+ } else {
+ document.getElementById('blink').style.color="white";
+ } // if
+
+ timer = setTimeout ("blink()", 450);
+} // blink
+
+function stoptimer () {
+ clearTimeout (timer);
+} // stoptimer
+</script>
+
+ <!-- Google Analytics
+ <script src="http://www.google-analytics.com/urchin.js" type="text/javascript">
+ </script>
+ <script type="text/javascript">
+ _uacct = "UA-89317-1";
+ urchinTracker ();
+ </script>
+ Google Analytics -->
+
+ <?php
+ include "../../php/clearscm.php";
+ menu_css ();
+ ?>
+</head>
+
+<body onload="blink()" onunload="stoptimer()" id="homepage">
+
+<?php heading ();?>
+
+<div id="page">
+ <div id="content">
+ <?php start_box ("cs2")?>
+ <h2 align=center><a href="http://defaria.com">Andrew P. DeFaria</a></h2>
+ <address style="text-align:center">
+ 11064 West Ocean Air Drive #230<br>
+ San Diego, California 92130-4605<br>
+ </address>
+ <p style="text-align:center">
+ Phone: 408-596-4937</a><br>
+ Email: <a href="mailto:Andrew@DeFaria.com">Andrew@DeFaria.com</a><br>
+<table align="center" width="400">
+ <tr>
+ <td>
+ <marquee behavior="alternate" onmouseover="this.stop()" onmouseout="this.start()"><a id="blink" href="Resume.doc">Download an MS Word copy!</a></marquee><br>
+ </td>
+ </tr>
+ <td align="center">
+ <center>
+ <font size=-1 class="dim">Sorry for the blink but for some reason recruiters can't find this link!</font></p>
+ </center>
+ </td>
+ </tr>
+</table>
+ <?php end_box ();?>
+
+ <h3>Objective</h3>
+
+ <p>To work with state of the art operating systems and networks to
+ insure the smooth running of an organization's information flow.</p>
+
+ <h3>Hardware</h3>
+
+ <p>Workstations and servers from Sun, HP, x86 class machines, dual core,
+ quad core, 32 and 64 bit.
+
+ <h3>Operating Systems</h3>
+
+ <p><span class="standout">Unix</span> (Solaris, HP-UX),
+ <span class="standout">Windows XP/Vista/Windows 7</span>,
+ <span class="standout">Linux</span> (Redhat, Ubuntu Desktop/Server,
+ Mandrake, SuSE, Redhat, LynuxOS).</p>
+
+ <h3>Networking</h3>
+
+ <p>Knowledge of TCP/IP, Ethernet, XP Firewall, DSL Routers, Windows
+ and Unix Networking (NIS/Automount/ftp/ping/etc), some <span
+ class="standout">Active Directory/LDAP</span> experience and <span
+ class="standout">Samba</span> experience.</p>
+
+ <h3>Software</h3>
+
+ <p><span class="standout">Clearcase</span>, <span
+ class="standout">Clearquest</span>, CVS, Apache, <span
+ class="standout">Build Forge</span>, <span
+ class="standout">VMWare</span>, <span class="standout">MySQL</span>,
+ Mozilla Firefox, Thunderbird, <span class="standout">Perl</span>,
+ <span class="standout">Bash</span>, <span
+ class="standout">PHP</span>, Emacs, CDE, C++, VUE 3.0 (Alpha
+ Tester), <a href="http://cygwin.com">Cygwin</a>. Also, various tools
+ and applications on Microsoft Windows too numerous to mention.</p>
+
+ <h3>Education</h3>
+
+ <p>A.A.S. in Computer Science from Union County College in Scotch
+ Plains, New Jersey.</p>
+
+ <p>Attended approximately one year at Fairleigh Dickenson
+ University, Rutherford, New Jersey, in pursuit of BS in Computer
+ Science, concentrating on computer courses. Have also attended San
+ Jose State University, Mission College and Chico State in pursuit of
+ my degree.</p>
+
+ <h3>References</h3>
+
+ <table align=center border=1 cellspacing=0 cellpadding=2 width="90%">
+ <tbody>
+ <tr>
+ <td><a href="http://www.linkedin.com/profile/view?id=14959116">David Petro</a></td>
+ <td>(425)-391-4185</td>
+ <td><a href="mailto:david.petro@ge.com">david.petro@ge.com</a></td>
+ <td>Manager, General Electric</td>
+ </tr>
+ <tr>
+ <td><a href="http://www.linkedin.com/profile/view?id=276869">Tom Connor</a></td>
+ <td>(512)-422-1172</td>
+ <td><a href="mailto:tomhillconnor@yahoo.com">tomhillconnor@yahoo.com</a></td>
+ <td>Coworker, Consultant</td>
+ </tr>
+ <tr>
+ <td><a href="http://www.linkedin.com/profile/view?id=700521">James Chen</a></td>
+ <td>(408)-845-5360</td>
+ <td><a href="mailto:jchen@salira.com">jchen@salira.com</a></td>
+ <td>Vice President of Engineering,<br>Salira Optical Network Systems</td>
+ </tr>
+ <tr>
+ <td><a href="http://www.linkedin.com/profile/view?id=12113821">Omair Ahmed</a></td>
+ <td>(224) 715-9786</td>
+ <td><a href="mailto:Omair.Ahmed@ge.com">omair.ahmed@ge.com</a></td>
+ <td>Coworker, General Electric</td>
+ </tr>
+ <tr>
+ <td><a href="http://www.linkedin.com/profile/view?id=1023014">Shivdutt Jha</a></td>
+ <td>(408)-806-3476</td>
+ <td><a href="mailto:shivdutt_jha@hotmail.com">shivdutt_jha@hotmail.com</a></td>
+ <td>Coworker, Consultant</td>
+ </tr>
+ </tbody>
+ </table>
+
+ <br>
+ <hr noshade>
+
+ <h2>Clients</h2>
+
+ <p><a href="http://www.broadcom.com"><img src="Broadcom.gif" alt="Broadcom" border="0"></a></p>
+
+ <p>December 2011 - Present<br>
+ <font class=dim>Contract</font><br>
+ <a href="http://defaria.com/blogs/Status/archives/cat_broadcom.html">Workblog</a></p>
+
+ <p>Worked as a Clearquest Designer and hook code writer. The Clearquest
+ database used Visual Basic. Implemented fixed and feature development for
+ Clearquest as well as wrote several Perl scripts to perform data maintenance as
+ required by utilizing ClearSCM's <a href="/php/cvs_man.php?file=lib/Clearcase.pm">Clearquest</a>
+ module. Also utilized <a href="/php/cvs_man.php?file=lib/Clearquest/Server.pm">Clearquest::Server<a/>,
+ <a href="/php/cvs_man.php?file=lib/Clearquest/Client.pm">Clearquest::Client</a>
+ and <a href="/php/cvs_man.php?file=lib/Clearquest/REST.pm">Clearquest::REST</a> modules.</p>
+
+ <p>Worked with <a href="http://www.electric-cloud.com/products/electriccommander.php">Electric
+ Commander</a> migrating a group from their unsupported build environment into
+ the standard Electric Commander based solution. This involved using Cygwin,
+ bash and LSF to farm builds out to a pool of Windows servers to perform builds.
+ Builds were down using Visual Studio 8.0, 9.0 and 10.0. Build system also used
+ Perforce and Perforce trigger to fire builds as the engineers checked in code.</p>
+
+ <p>Implemented Perl module, <a href="/php/cvs_man.php?file=lib/Clearquest/REST.pm">Clearquest::REST</a>,
+ to replace a <a href="http://clearscm.com/clearquest/cqd/">Clearquest Daemon</a>
+ that was in use so that systems that did not have Clearquest installed (e.g.
+ Linux build machines) could talk to Clearquest to update defects when required.
+ Modified Perforce and Git triggers to use this REST interface.</p>
+
+ <p>Served as a mentor to the group on issues of programming in Perl as well as
+ using and configuring Eclipse IDE.</p>
+
+ <hr noshade>
+
+ <p><a href="http://www.tellabs.com"><img src="Tellabs.gif" alt="Tellabs" border="0"></a></p>
+
+ <p>March 2011 - December 2011<br>
+ <font class=dim>Contract</font><br>
+
+ <p>Automated various informational systems using Perl/MySQL/Oracle and the
+ web. This often involved transforming data from far away databases to more
+ local data structures for presentation on the local Intranet.</p>
+
+ <p>Developed a command line debugger called raid which provided a consistent
+ interface with complete command history and variable substitution. This Perl
+ process utilized Inline::C to interface to the developer libraries and provide
+ a consistent interface for the various command line debuggers developed by
+ various different groups.</p>
+
+ <p>Modified and extended a serious of web pages and graphs to extend the
+ functionality of Mercury Quality Center, interfacing to Test Directory's
+ SQL database to the web giving project manager's drill down functionality
+ regarding testing activities to an unprecedended level.</p>
+
+ <hr noshade>
+
+ <p><a href="https://www2.gehealthcare.com/portal/site/usen"><img src="GEHealthcare.gif" alt="General Electric" border="0"></a></p>
+
+ <p>January 2010 - December 2010<br>
+ <font class=dim>Contract</font><br>
+ <a href="http://defaria.com/blogs/Status/archives/cat_general_electric.html">Workblog</a></font>
+
+ <p>Performed Clearcase/Clearquest administration with an emphasis on
+ UCM administration. Wrote several Perl scripts including an <a
+ href="http://clearscm.com/php/cvs_man.php?file=cc/etf.pl">Evil Twin
+ Finder</a>. Created UCM Projects and streams as appropriate as well
+ as created and updated Build Forge jobs to automate work
+ flow. Assisted in consultations with UCM concepts such as
+ component/composite baselines and projects. Wrote Perl scripts for
+ conversions of Clearquest data with other systems (Siebel).</p>
+
+ <hr noshade>
+
+ <p><a href="http://www.gdc4s.com"><img src="General_Dynamics_logo.jpg" alt="General Dynamics" border="0"></a></p>
+
+ <p>June 2007 - October 2009<br>
+ <font class=dim>Contract</font><br>
+ <a href="http://defaria.com/blogs/Status/archives/cat_general_dynamics.html">Workblog</a></font>
+
+ <p>Served as Clearcase/Clearquest Administrator, Build Release and
+ Automation using Perl scripts. Implemented several enhancements and
+ new functionality with a C++/Qt application that integrates the highly
+ specialized UCM/Clearquest integrated environment into one tool.</p>
+
+ <p>Instrumental in establishment of Perl standards and introduction of
+ Perl tools such as <a href="http://perlcritic.com/">Perl::Critic</a> and
+ <a href="http://perltidy.sourceforge.net/">Perl::Tidy</a>. Worked at promoting
+ usage of CPAN modules.</p>
+
+ <p>Developed an extensive test driver application in Perl to
+ interface and drive tests using <a
+ href="https://www.nethawk.fi/products/nethawk_simulators/">NetHawk EAST Simulators</a>
+ as well as interfacing to other simulators and external hardware. The
+ system automates the running of regression tests, official testing before
+ the customer, assists with validation of test results, collecting of log
+ files, checking log files into Clearcase and records status into a MySQL
+ database. Developed a PHP web page to present the data in various forms
+ including graphs, reports, exporting to CSV files and emailing of reports.
+ Implemented maintenance programs to scrub and keep the data clean. This system
+ was instrumental in Functional Quality Testing for the
+ <a href="http://en.wikipedia.org/wiki/Mobile_User_Objective_System">MUOS</a>
+ program.</p>
+
+ <p>Worked on many enhancements to the extensive Clearquest system in use
+ at GD. Designed and developed the record set implementing node configurations.
+ Implemented required forms and action hook code. Designed and developed Perl
+ scripts to initially load data into the new records.</p>
+
+ <p>Developed a server process (daemon) to process baseline records that were
+ then tracked by Clearquest. Implemented scripts to create baseline records
+ from other automated process such as Build Forge. Tied together baseline
+ records with node configurations through action hook code.</p>
+
+ <p>Participated in code reviews for all production code.</p>
+
+ <hr noshade>
+
+ <p><a href="http://ti.com"><img src="TexasInstruments.jpg"
+ alt="Texas Instruments" title="Texas Instruments" border=0></a></p>
+
+ <p>October 2006 - June 2007<br>
+ <font class=dim>Contract</font><br>
+ <a href="http://defaria.com/blogs/Status/archives/cat_texas_instruments.html">Workblog</a></font>
+
+ <p>Serving as Clearcase/Clearquest Administrator working with Perl
+ scripts and Clearquest schemas. Responsible for development and
+ deployment of a Perl/Oracle application to track information about
+ projects worldwide. Also wrote, modified and maintained several
+ scripts for tracking Clearcase license usage and load balancing of
+ Clearquest web servers.</p>
+
+ <hr noshade>
+
+ <p><a href="http://hp.com"><img src="HPLogo.gif" alt="Hewlett
+ Packard Company" title="Hewlett Packard Company" border=0></a></p>
+
+ <p>February 2006 - October 2006<br>
+ <font class=dim>Contract</font><br>
+ <a href="http://defaria.com/blogs/Status/archives/cat_hewlett_packard.html">Workblog</a></p>
+
+ <p>Managed and executed day to day build and release duties. Served
+ as Clearcase/Clearquest Administrator as well as overall support of
+ systems. Assisted with creating UCM streams and handling of rebase
+ and delivery issues for engineers and the build/release process.
+ Wrote UCM triggers to notify users of deliveries from UCM
+ development streams. Created baselines for official builds. Took
+ over day to day build and release duties. Created a build script
+ that united the various quick and dirty build scripts that were
+ oriented per stream and per build option. This standardized the
+ build process. Augmented this build script to be a daemon that
+ continually builds software when deliveries are detected. Wrote a
+ build status web page that tracks and monitors the continuous
+ building. Created a dynamic web page to show Junit test
+ history. Converted Windows build from bat files and scheduled tasks
+ -> Cygwin and cron thus making the build script identical on both
+ Linux and Windows.</p>
+
+ <hr noshade>
+
+ <p><a href="http://www.broadcom.com"><img src="Broadcom.gif"
+ alt="Broadcom" title="Broadcom" border="0"></a></p>
+
+ <p>September 2005 - January 2006<br>
+ <font class=dim>Contract</font><br>
+ <a href="http://defaria.com/blogs/Status/archives/cat_broadcom.html">Workblog</a></p>
+
+ <p>Served as Clearcase/Clearquest Administrator as well as overall
+ support of systems. Developed several <a
+ href="/clearcase/triggers.php">triggers</a> as
+ well as ported my <a
+ href="/clearcase/triggers.php">mktriggers</a>
+ script which automates the maintenance of triggers.</p>
+
+ <p>Developed a complex <a
+ href="/clearquest/db.php">Perl script</a> to
+ merge two Clearquest databases to a new database with many schema
+ changes. This script handled all aspects of the conversion including
+ changing non US ASCII characters found in the data to their HTML
+ equivalents, dynamic creation of dynamic lists, field renaming and
+ dynamically creating new stateless records as needed.</p>
+
+ <p>Developed a script to better handle merging from UCM deliveries
+ and rebases by delaying any non automatic merges to the end of the
+ process as well as handle binary element merge. This process,
+ written in Perl, utilized PerlTk to present the user with a GUI
+ dialog box to choose which version of the binary file to merge.</p>
+
+ <p>Designed and developed another Clearquest database for the Mobile
+ Multimedia group.</p>
+
+ <p>Wrote several other scripts including one to interface CVS to IMS
+ (a defect tracking system) recording the change set at commit time,
+ a script to strip out MIME/HTML and attachments for defects
+ submitted to GNATS (another defect tracking system). Also
+ implemented several script to log Clearcase activity, check
+ Clearcase's pulse and gather site and vob statistics. These scripts
+ were the start for creation of a set Object Oriented Perl modules to
+ encapsulate Clearcase in a Perl like manner (still in
+ development).</p>
+
+ <hr noshade>
+
+ <p><a href="http://lynuxworks.com"><img src="LynuxWorks.gif"
+ alt="LynuxWorks" title="LynuxWorks" border="0"></a></p>
+
+ <p>December 2004 - September 2005<br>
+ <a href="http://defaria.com/blogs/Status/archives/cat_lynuxworks.html">Workblog</a></p>
+
+ <p>Served as a build engineer in the Integration Group responsible
+ for building LynxOS (Linux RTOS) as well as tool chains, testing,
+ releasing and process improvement. LynuxWorks uses CVS for version
+ control.</p>
+
+ <p>Developed a process of providing full text search of the
+ company's defect database using Perl and Htdig (See <a
+ href="/scripts/ecrd">ECRDig</a>). Developed a web
+ based report to show CVS activity as well as several other CVS
+ related utilities(See <a href="http://defaria.com/Resume/cvs_utilities">CVS Utilities</a>) as
+ well as report on the differences between two CVS tags. Automated
+ the build process so that nightly builds could be
+ performed. Developed a web application that allows one to maintain
+ CVS account information including account creation,
+ setting/resetting of password, etc.</p>
+
+ <hr noshade>
+
+ <p><a href="http://ameriquest.net"><img src="Ameriquest.gif"
+ alt="Ameriquest Mortgage Company" title="Ameriquest Mortgage
+ Company" border=0></a></p>
+
+ <p>March 2004 - December 2004<br>
+ <font class=dim>Contract</font><br>
+ <a href="http://defaria.com/blogs/Status/archives/cat_ameriquest.html">Workblog</a></p>
+
+ <p>Served as Clearcase/Clearquest administrator to this major
+ mortgage company. As Ameriquest is just starting out I have been
+ busy with importing source code from flat file systems as well as
+ PVCS and Visual Source Safe. Also setting up vobs and regions taking
+ into account security restrictions and concerns. Assisted with
+ designing of the Multisite scheme to India. Participated in design
+ of UCM model to be used for Ameriquest.</p>
+
+ <hr noshade>
+
+ <p><a href="http://www.salira.com"><img src="Salira.gif" alt="Salira
+ Optical Network Systems" title="Salira Optical Network Systems"
+ border=0></a></p>
+
+ <p>August 2001 - February 2004<br>
+ <a href="http://defaria.com/blogs/Status/archives/cat_salira.html">Workblog</a></p>
+
+ <p>After consulting briefly with Salira Optical Network Systems I
+ joined this startup company serving in the role of <span
+ class="standout">Clearcase/Clearquest Administrator</span> for this
+ mostly Windows shop. I helped others in setting up the
+ Clearcase/Clearquest environment as well as provided <a
+ href="http://defaria.com/Resume/Training">Training</a>.</p>
+
+ <p>I also served in the role of <span class="standout">Release
+ Engineer</span> managing the build process. I employed wide usage of
+ <a href="http://Cygwin.com">Cygwin</a>, which is a product that
+ provides an extremely workable Unix like environment and engineered
+ a build environment around that using <span class="standout">GNU
+ make</span> and other standard Unix and GNU utilities. When users
+ complained that building remotely was slow I performed <a
+ href="http://defaria.com/Resume/SmakeOpt">an analysis on build
+ performance</a>. I also performed <a
+ href="http://defaria.com/Resume/BuildPerf">Build Stress Testing</a>
+ where I characterized the effect of multiple simultaneous builds
+ performed on the server.</p>
+
+ <p>I also setup and developed their <span
+ class="standout">Clearquest</span> bug tracking system as well as
+ served as an advisor/expert on Clearcase issues, branching
+ strategies, labeling and release management.</p>
+
+ <p>While working at Salira I designed and developed a tool in C that
+ packaged the product into a more compact form.</p>
+
+ <p>I designed and implemented a <a
+ href="/clearquest/cqd">Clearquest Daemon</a>
+ which served as an interface between processes and Clearquest
+ data. This daemon serviced requests from web pages and triggers in
+ order to get and validate data from Clearquest.</p>
+
+ <p>Developed release web pages that managed releases and produced
+ release notes for every release.</p>
+
+ <p>Developed process automation scripts to perform automatic branch
+ merging and syncing.</p>
+
+ <p>Performed product installation testing for the web component on
+ <span class="standout">Linux (SuSE)</span> and <span
+ class="standout">Solaris</span> as well as browser testing
+ (Netscape).</p>
+
+ <p>Implemented test scaffolding in <span
+ class="standout">TCL/TK</span> for test automation.</p>
+
+ <hr noshade>
+
+ <p><a href="http://www.hp.com"><img src="HPLogo.gif" alt="Hewlett
+ Packard Company" title="Hewlett Packard Company" border=0></a></p>
+
+ <p>August 1999 - February 2001<br>
+ <font class=dim>Contract</font><br>
+
+ <h3><a href="http://hprasmg.cup.hp.com/Org/STD.html"> Systems
+ Technology Division</a></h3>
+
+ <h4><a href="http://pdlweb.cup.hp.com">Enterprise Java Lab</a></h4>
+
+ <p>Setup security system automating the running of Medusa (an
+ internal security audit tool) on approximately 100 machines. Reports
+ are generated automatically and are viewable on the web. Setup and
+ maintained security related patch depots.</p>
+
+ <p>Implemented nightly automation for the lab's machines including
+ security checks, automatic installation of line printer models,
+ etc. This automation was bundled into an SD-UX bundle.</p>
+
+ <p>Migrated user data to HP NetStorage 6000. Worked extensively with
+ HP NetStorage 6000 Support on problems with this machines OS and
+ interfacing with Windows 2000.</p>
+
+ <p>Migrated HP-UX applications from one application server to
+ another.</p>
+
+ <p>Participated in several critical planned networked down times
+ where the team was able to implement changes to the infrastructure,
+ including migration to Clearcase 4.0, migration of project and user
+ data to HP NetStorage 6000's and other such changes.</p>
+
+ <p>Set up Netscape Enterprise Web Server and iPlanet 4.1 Web
+ Server.</p>
+
+ <hr noshade>
+
+ <p><a href="http://www.cisco.com"><img src="Cisco.gif" alt="Cisco
+ Systems" title="Cisco Systems" border=0></a></p>
+
+ <p>March 1999 - August 1999<br>
+ <font class=dim>Contract</font><br>
+
+ <p>Served as Clearcase/Unix Systems Administrator. Responsible for
+ all Clearcase operations in CNS/AD on Sun Solaris, HP-UX, Windows NT
+ 4.0 and Windows 2000. Assisted in creating additional View and Vob
+ servers and balancing the Clearcase load amongst them. Participated
+ in Rational's Beta program for Windows 2000. Installed, tested and
+ documented Clearcase on Windows 2000 as well as Windows NT 4.0.</p>
+
+ <p>Assisted in recovery of a catastrophic disk failure in a critical
+ vob. Assisted with implementing a backup strategy with Arcserve
+ Open. Helped evaluate system monitoring packages.</p>
+
+ <p>As CNS/AD was in a secured and isolated network, learned and
+ assisted users with ssh/scp.</p>
+
+ <hr noshade>
+
+ <p><a href="http://www.sun.com"><img src="Sun.jpg" alt="Sun
+ Microsystems" title="Sun Microsystems" border=0></a></p>
+
+ <p>December 1998 - March 1999<br>
+ <font class=dim>Contract</font><br>
+
+ <p>Worked on the Sunpeak Configuration Management team performing
+ promotions of code updates into test and production
+ environments. Also worked on improving the process flow of
+ promotions utilizing make and rdist.</p>
+
+ <hr noshade>
+
+ <p><a href="http://www.hp.com"><img src="HPLogo.gif" alt="Hewlett
+ Packard Company" title="Hewlett Packard Company" border=0></a></p>
+
+ <p>February 1988 - November 1998<br>
+ <font class="dim">(60-Level Software Engineer)</font>
+
+ <h3><a href="http://hprasmg.cup.hp.com/Org/STD.html">Systems
+ Technology Division</a></h3>
+
+ <h4><a href="http://cllweb.cup.hp.com">California Language
+ Labs</a></h4>
+
+ <p>Primary Clearcase and Multisite Administrator for a large
+ Clearcase environment with approximately 1400 views and 180
+ vobs. Most vobs are multisited between several other labs and I am
+ responsible for resolving Multisite problems. I also serve as
+ general System Administrator, overseeing approximately 400 machines
+ in the lab. I help institute policies and procedures to keep the
+ network running smoothly. Also participate in the design and
+ restructuring the network topology and Clearcase topology by bring
+ in many Kittyhawks, Mohawks and Bravehawks (about 40 of them) for
+ use as Clearcase Vob, View and Build, Mail, Application, X Terminal
+ and Web servers. Assist in documenting setup and configuration as
+ well as trouble shooting and handling of patches for all lab wide
+ shared resources.
+
+ <p>Responsible for setup and running of Windows NT domain, account
+ setup and print serving. Setup and evaluated Clearcase 3.2 on
+ NT. Developed backup strategy for NT systems. Maintain a repository
+ of software tools as well as evaluated and recommended several PC
+ packages for lab usage. Main point of contact for Windows 95/NT
+ problem solving in the lab. Also sought after by many people in
+ Hewlett Packard relating to both PC and Unix configurations and
+ problem solving.</p>
+
+ <p>Also served as webmaster for the lab as well as consult on HTML
+ questions and design issues. Installed, configured and maintain the
+ <a href="http://home.netscape.com"> Netscape </a> Suitespot Servers
+ including the Enterprise and Directory servers. Developed several
+ web pages and forms for the lab as well as run <a
+ href="http://defaria.com/q/">The Unofficial Quicken® Web
+ Page</a>.</p>
+
+ <p>I developed an <i><a
+ href="http://cllweb.cup.hp.com/productivity/AppServer/"> Application
+ Server</a> </i> providing many machines with many software packages
+ without the need for individual system administration utilizing
+ scripting and NFS heavily.</p>
+
+ <p>Prior to the Productivity Project I worked on COBOL/SoftBench
+ product which consists of encapsulating some core <i><a
+ href="http://hpcll50.cup.hp.com/"> HP Micro Focus COBOL</a> </i>
+ tools using C++ 3.0 and the SoftBench Encapsulator libraries. Also,
+ working on porting an X/Motif application to MS Windows 3.1. The
+ code is written using C++ 3.0 on both the HP workstation and the PC
+ (Borland C++ 3.1).</p>
+
+ <p>Worked in the Ada project on Ada/SoftBench. This project was
+ similar to COBOL/SoftBench in that it involved some SoftBench
+ encapsulations using a language called edl.</p>
+
+ <p>Worked producing Ada Bindings to Xlib, Xt and Motif. This
+ involved using a modified C compiler to translate C header and
+ source files to Ada declarations and function prototypes. Using this
+ methodology we were able to migrate our product from X11 R3 and
+ Motif 1.0 to X11 R4 and Motif 1.1 in one week!</p>
+
+ <p>Worked on a project that produced Ada Bindings to HP-UX, which
+ enabled me to get good breath knowledge into all system calls, and
+ another binding to Starbase graphical subsystem.</p>
+
+ <p>Performed destructive testing on MPE/XL 1.0-1.3. Wrote several
+ programs to stress the OS. Submitted 300+ Service Requests many of
+ which appeared on Must Fix lists.</p>
+
+ <hr noshade>
+
+ <?php start_box ("cs2")?>
+ <a name="copyleft"></a>
+ <p style="color:#666">This resume is freely available; you can
+ redistribute it and/or modify it under the terms of the GNU
+ General Public License as published by the Free Software
+ Foundation; either version 2 of the License, or (at your option)
+ any later version. This means that if you modify this resume you
+ must include a copy of the original source or refer to its origin
+ at <a href="http://clearscm.com/Resumes/Andrew">http://clearscm.com/Resumes/Andrew</a>.</p>
+
+ <p style="color:#666">This resume is distributed in the hope
+ that it will be useful, but WITHOUT ANY WARRANTY; without even
+ the implied warranty of MERCHANTABILITY or FITNESS FOR A
+ PARTICULAR PURPOSE. See the GNU General Public License for more
+ details.</p>
+
+ <p style="color:#666">You should have received a copy of the GNU
+ General Public License along with this resume; if not, write to
+ the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+ Boston, MA 02111-1307, USA.</p>
+ </font>
+ <?php end_box ();?>
+
+ <?php copyright ("1988");?>
+
+<script language="JavaScript" src="/JavaScript/Menus.js" type="text/javascript"></script>
+
+</body>
+</html>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+ <title>ClearSCM: Our People: Don Skanes</title>
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Article.css">
+ <link rel="stylesheet" type="text/css" media="print" href="/css/Print.css">
+ <link rel="SHORTCUT ICON" href="http://clearscm.com/favicon.ico" type="image/png">
+ <?php
+ include "../../php/clearscm.php";
+ menu_css ();
+ ?>
+</head>
+
+<body id="homepage">
+
+<?php heading ();?>
+
+<div id="page">
+ <div id="content">
+ <?php start_box ("cs2")?>
+ <h2>Donald G. Skanes</h2>
+
+ <p style="text-align:center"><a href="DonSkanes.doc">MS Word format</a></p>
+ <?php end_box ();?>
+
+ <h3>Summary</h3>
+
+ <p>Highly skilled senior software engineer with over 27 years of
+ experience. Special strengths in the areas of design and
+ implementation of Software Configuration Management tools, operating
+ systems, programming languages, compilers, databases, system
+ validation tools, build and deployment automation.</p>
+
+
+ <h3>Operating Systems</h3>
+
+ <p>Highly skilled in <span class="standout">Windows</span>, <span
+ class="standout">Unix</span>, and <span
+ class="standout">MacOS</span> operating systems.
+
+ <h3>Software</h3>
+
+ <p>Extensive Experience in Rational's <span
+ class=standout>ClearCase</span> and <spn class=standout>ClearCase
+ UCM</spn> for UNIX and Windows Vista/XP/2000/2003, <span
+ class=standout>ClearQuest</span>, <span class=standout>C#</span>,
+ <span class=standout>.Net</span>, <span class=standout>Visual Basic
+ 6</span>, <span class=standout>Perl</span>, <span
+ class=standout>C/C++</span>, Qt, Make, Tcl/TK, <span
+ class=standout>Java</span>, MS Access, <span class=standout>SQL
+ Server</span>, Oracle, Install Shield, GNU tools, C shell, Bourne
+ shell and BASH.
+
+ <h3>Education</h3>
+
+ <p>B. Sc. Computer Science - Memorial University of Newfoundland,
+ Canada, 1981</p>
+
+ <h2>Clients</h2>
+
+ <hr noshade>
+
+ <h3>ACC Capital Holdings Corporation</h3>
+
+ <p>Nov 21, 2005 - Present<br>
+ Manager, Configuration Management</p>
+
+ <p>Summary of responsibilities:</p>
+
+ <ul>
+ <li>CM Manager responsible for the Rational tool administration
+ for ClearCase and Team Unifying Platform. Provide mentorship and
+ leadership to other CM team members from various organizations
+ within ACC Capital Holdings, Ameriquest, AMC Mortgage Services,
+ Tavant Technologies and Argent Mortgage.</li>
+
+ <li>Provided enterprise solutions and for Configuration Management,
+ Change Management and Release Management for several lines of
+ business.</li>
+
+ <li>Responsible for providing training and documentation including
+ charters, requirements and CM plans for various CM teams.</li>
+
+ <li>Corporate subject matter expert for Rational Tools and
+ Configuration Management.</li>
+
+ <li>Managed a large team of CM, Tools, Build and Release engineers
+ for various Mortgage application systems.</li>
+
+ <li>Lead the rollout of ClearCase UCM and ClearQuest for one of
+ the largest software development shops in US.</li>
+ </ul>
+
+ <hr noshade>
+
+ <p><a href="http://www.aspenconsult.com/home.htm"><img
+ src="Aspen.gif" alt="Aspen Software Consultants" title="Aspen
+ Software Consultants" border=0></a></p>
+
+ <p>Jan 2005 - Nov 2005<br>
+ <font class=dim>Contract</font><br>
+ Senior CM Administrator, Argent Mortgage</p>
+
+ <p>Summary of responsibilities:</p>
+
+ <ul>
+ <li>Administration of IBM's Rational ClearCase and ClearQuest
+ included providing consulting and mentorship to development and
+ Configuration Management and Release Management members as well as
+ development teams.</li>
+
+ <li>Coordinated and implementation of approximately 75 ClearCase
+ UCM projects integrated with ClearQuest and Test Director in
+ addition to providing training, ongoing support and
+ mentorship.</li>
+
+ <li>Responsible for documenting CM plans and training Job aides
+ for implementing CM processes and procedures in addition to naming
+ standards for CM and development teams.</li>
+
+ <li>Developed tools and triggers using Perl and C for ClearCase
+ integrations to applications such as Empower, Oracle and various
+ stream automated deliver and deployment operations.</li>
+
+ <li>Designed and developed build automation tools from within
+ ClearCase UCM which incorporated information derived from within
+ ClearQuest Build Request implementations using the CQ API and
+ Perl.</li>
+
+ <li>Provided automated scripts and worked with the build and
+ deployment teams to improve processes to deploy applications to
+ integration, test, certification, and production financial
+ systems</li>
+ </ul>
+
+ <p>April 2004 - Dec 2005<br>
+ <font class=dim>Contract</font><br>
+ Senior CM Strategist for Ameriquest Mortgage<br>
+ ADS Program Management Office</p>
+
+ <p>Summary of Responsibilities:</p>
+
+ <ul>
+ <li>SCM Responsibilities using IBM's Rational ClearCase included
+ providing training and mentorship to the current CM members, in
+ addition to developments and QA teams.</li>
+
+ <li>Participated in the coordination and roll out of approximately
+ 2000 clients and 100 ClearCase UCM projects.</li>
+
+ <li>Developed tools and triggers for ClearCase integrations to
+ applications such as Informatica.</li>
+
+ <li>Responsible for documenting CM plans and training Job aides
+ for implementing CM processes and procedures in addition to naming
+ standards for CM and development teams.</li>
+
+ <li>ClearCase and ClearQuest administration including
+ Multisite.</li>
+ </ul>
+
+ <hr noshade>
+
+ <h3>Mindlance Corporation</h3>
+
+ <p>Mar 2003 - Feb 2004<br>
+ SCM Consultant for INTEL Corporation<br>
+ Tools and Environment team in CPD - Folsom, Ca</p>
+
+ <p>Summary of responsibilities:</p>
+
+ <ul>
+ <li>Software Configuration Management responsibilities using IBM's
+ Rational ClearCase included providing consulting and mentorship to
+ the current SCM team members in addition to development sponsored
+ subject matter experts.</li>
+
+ <li>Application Development and implementation using Windows XP,
+ C#, Visual Basic 6, Perl and SQL Server 2000.</li>
+
+ <li>Designed and implemented tools and triggers to enhance the
+ ClearCase Software Configuration Management system. This included
+ a client/server transaction based service which executes SCM tasks
+ across networks in an effort to enhance ClearCase Multi site
+ capabilities.</li>
+
+ <li>ClearCase administration duties including multisite to
+ Bangalore.</li>
+
+ <li>Documentation provided for various policies and procedures for
+ CM.</li>
+ </ul>
+
+ <hr noshade>
+
+ <p><a href="http://www.edentreetech.com/"><img src="Edentree.jpg"
+ alt="Edentree Technologies" title="Edentree Technologies"
+ border=0></a></p>
+
+ <p>May 2002 - Feb 2003<br>
+ Senior Software Engineer, Software Development</p>
+
+ <p>Summary of responsibilities:</p>
+
+ <ul>
+ <li>Software Configuration Management responsibilities using
+ Visual SourceSafe</li>
+
+ <li>Application Development using Visual Basic, Python, C/C++,
+ TCL, Perl, Java and Aspect (Procomm). Designed and implemented a
+ universal interface for client implementation for the CONNECT_ET®
+ product.</li>
+
+ <li>Designed and implemented an application level protocol for a
+ Client Server application using sockets and TCP/IP.</li>
+
+ <li>Designed various GUI and applications for a new test
+ automation product line using Visual Basic and C++ with Qt on both
+ Windows and Unix Operating Systems.</li>
+
+ <li>Designed and implemented a database interface for client
+ server applications</li>
+ </ul>
+
+ <hr noshade>
+
+ <p><a href="http://www.zhone.com/"><img src="Vpacket.png"
+ alt="Vpacket Communications, Inc. (now Zhone Technologies)"
+ title="Vpacket Communications, Inc. (now Zhone Technologies)"
+ border=0></a></p>
+
+ <p>Mar 2001- Apr 2002<br>
+ Senior Software Engineer, Software Configuration Management</p>
+
+ <p>Summary of responsibilities:</p>
+
+ <ul>
+ <li>Designed and implemented a software version control system
+ utilizing ClearCase as the software development
+ environment. Provided ClearCase support to the development
+ groups.</li>
+
+ <li>Architected and documented software process definitions in
+ correspondence with ClearCase Unified Change Management (UCM)
+ policies and procedures derived business requirements.</li>
+
+ <li>Designed and implemented an automated software build system,
+ and provided regular builds to the software development
+ groups.</li>
+
+ <li>Coordinated multi-site support SCM team between the Vpacket
+ sites.</li>
+
+ <li>Designed and implemented a Bug Tracking schema using
+ Rational's ClearQuest.</li>
+ </ul>
+
+ <hr noshade>
+
+ <p><a href="http://www.nortel.com/"><img src="Nortel.gif"
+ alt="Nortel Networks, Inc." title="Nortel Networks, Inc."
+ border=0></a></p>
+
+ <p>1997- 2001</p>
+
+ <h4>Desktop Environment Support</h4>
+
+ <p>Desktop Environment support entailed the following responsibilities:</p>
+
+ <ul>
+ <li>Port of a Solaris based development environment to Windows
+ NT.</li>
+
+ <li>ClearCase software version control system support
+ activities.</li>
+
+ <li>Make file support for the overall development environments
+ build system.</li>
+
+ <li>Windows NT environment support tools such as ClearCase, Wind
+ Rivers Tornado products and Cygwin's BASH (Bourne Again
+ Shell).</li>
+
+ <li>Windows NT and UNIX interoperability support issues.</li>
+ </ul>
+
+ <h4>ClearCase Administration and software development tools
+ developer</h4>
+
+ <p>The following responsibilities were performed as part of this
+ position:</p>
+
+ <ul>
+ <li>ClearCase VOB (Version Object Base) Administration. Comparable
+ to database administration type activities such as VOB layout, and
+ ongoing maintenance.</li>
+
+ <li>Multi-site software development support using the Rational's
+ ClearCase multi-site capability to provide multiple sites (4) the
+ capability of updating the same source code.</li>
+
+ <li>Tool development for developer productivity and process
+ control based around the ClearCase development environment.</li>
+
+ <li>Tool development for an API between ClearCase and a
+ proprietary problem tracking system.</li>
+
+ <li>Tool development of a SQL database used for reporting
+ different aspects of the software build and software release
+ process.</li>
+
+ <li>Product software load build process support activities.</li>
+ </ul>
+
+ <hr noshade>
+
+ <p><a href="http://www.nortel.com/"><img src="Nortel.gif"
+ alt="Nortel Networks, Inc." title="Nortel Networks, Inc."
+ border=0></a></p>
+
+ <h3>Northern Telecom Canada Ltd./Bell-Northern Research</h3>
+
+ <p>1981-1996</p>
+
+ <h4>ClearCase Administrator and software development tools developer</h4>
+
+ <p>Investigated and prototyped ClearCase implementations using base
+ ClearCase and Perl. Small projects were migrated from a proprietary
+ CM tool to ClearCase. ClearCase Multi-site was implemented from
+ Ottawa to Billerica, Raleigh and Simi Valley.</p>
+
+ <h4>WEB Administrator</h4>
+
+ <p>This activity entailed the administration of a Web site used
+ within a directorship. It involved the maintenance of the Web site
+ as well as keeping the HTML based information system up to date.</p>
+
+ <h4>Load Build Support</h4>
+
+ <p>Provided load build support to a team preparing release software
+ loads to customers. Build scripts developed and deployed using
+ ClearCase, RCS and PLS.</p>
+
+ <h4>Software Developer - X.25</h4>
+
+ <p>Developed a software trace facility for an X.25 system for a
+ proprietary product that enabled remote tracing capabilities</p>
+
+ <h4>Software Developer - NUI</h4>
+
+ <p>Developed a NUI (Network User Interface) database based on a
+ VAX/VMS with X.25 and ITI interfaces into a proprietary product line
+ to facilitate X.25 and X.29 NUI capabilities</p>
+
+ <h4>Software Developer - Network Management Systems</h4>
+
+ <p>Implemented a data collection facility for the inception of
+ statistics received from various proprietary devices</p>
+
+ <h4>System Administration</h4>
+
+ <p>Provided system administration for a broad range of VAX/VMS
+ systems and VAX clusters</p>
+
+ <h4>Software Verification</h4>
+
+ <p>Participated on a team of validation members responsible for
+ testing various network protocols on proprietary product
+ platforms</p>
+
+ <hr noshade>
+
+ <h3>Technical Summary</h3>
+
+ <p>Extensive Experience in Rational's ClearCase and ClearCase UCM
+ for UNIX and Windows Vista/XP/2000/2003, ClearQuest, C#, .Net,
+ Visual Basic 6, Perl, C/C++, Qt, Make, Tcl/TK, Java, MS Access, SQL
+ Server, Oracle, Install Shield, GNU tools, C shell, Bourne shell and
+ BASH.</p>
+
+ <p>Highly skilled in Windows, UNIX, and MacOS operating systems.</p>
+
+ <p>Member of IEEE and IEEE Computer Society.</p>
+
+ <p>Attended Rational Conferences in 1998 and 2000 (presentation
+ provided in 2000 on UCM)</p>
+
+ <p>Strong communication skills. Strong interpersonal skills. Fast
+ learner.</p>
+
+ <p>References: strong references available upon request.</p>
+
+ <p>Citizenship: Canadian on TN Visa in US since 1997</p>
+
+ <?php start_box ("cs2")?>
+ <a name="copyleft"></a>
+ <p style="color:#aaa">This resume is freely available; you can
+ redistribute it and/or modify it under the terms of the GNU
+ General Public License as published by the Free Software
+ Foundation; either version 2 of the License, or (at your option)
+ any later version.</p>
+
+ <p style="color:#aaa">This resume is distributed in the hope
+ that it will be useful, but WITHOUT ANY WARRANTY; without even
+ the implied warranty of MERCHANTABILITY or FITNESS FOR A
+ PARTICULAR PURPOSE. See the GNU General Public License for more
+ details.</p>
+
+ <p style="color:#aaa">You should have received a copy of the GNU
+ General Public License along with this resume; if not, write to
+ the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+ Boston, MA 02111-1307, USA.</p>
+ </font>
+ <?php end_box ();?>
+
+ <?php copyright ("1987");?>
+
+<script language="JavaScript" src="/JavaScript/Menus.js" type="text/javascript"></script>
+
+</body>
+</html>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+ <title>ClearSCM: Our People: Tom Connor</title>
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Article.css">
+ <link rel="stylesheet" type="text/css" media="print" href="/css/Print.css">
+ <link rel="SHORTCUT ICON" href="http://clearscm.com/favicon.ico" type="image/png">
+ <?php
+ include "../../php/clearscm.php";
+ menu_css ();
+ ?>
+</head>
+
+<body id="homepage">
+
+<?php heading ();?>
+
+<div id="page">
+ <div id="content">
+ <?php start_box ("cs2")?>
+ <h2>Kevin L. Haralson</h2>
+ <p style="text-align:center">System Administrator<br>
+ <a href="kevinharalson@ddct.org">kevinharalson@ddct.org</a>
+ <p style="text-align:center"><a href="Resume.doc">MS Word format</a></p>
+ <?php end_box ();?>
+
+<h2>Objective</h2>
+
+<p>19 years experience in the IT field. 5 years as a manager,
+overseeing projects, and/or budgets. 4 years in a technical sales
+capacity, and 10 years as a Technician (Tech Support/Helpdesk to
+Desktop/Hardware/Config Tech to System Admin to Network Admin).</p>
+
+<p>In the last 3 years I have been involved in building the
+infrastructure for medical, legal and financial offices, including
+installing most/all of their industry specific software. I've worked
+in three large organizations (over 2000 employees) as an IT Tech, and
+a number of smaller organizations (20 - 200 employees) from help desk
+to director of IT.</p>
+
+<p>My hope is to be a part of an exciting environment of growth and
+collaboration, or to help build a group/organization that possess
+these qualities.</p>
+
+<h2>Professional Skills</h2>
+
+<ul>
+ <li><b>Platforms</b>: X86 (Standard PC, Linux), Sun, HP, Dell, DEC, Sony,
+ IBM</li>
+
+ <li><b>O/S</b>: MS Windows NT4.0 (Servers), 9.x, 2K(Servers & Pro),
+ XP (2003 Servers and Pro), Vista (SP1- testing), UNIX: Solaris,
+ Linux (installations, maintenance, and troubleshooting)</li>
+
+ <li><b>Networking</b>: AD, WINS, DNS, NIS, NFS, SAMBA, SNMP, LDAP,
+ VTP, VLAN, STP, RIP, BGRP, EIGRP, NTP, Trunking</li>
+
+ <li><b>Backup</b>: Legato, Solstice Disk Suite (Sun),
+ Veritas(Symantec) (Standard backup procedure or as apart of Disaster
+ Recovery solution)</li>
+
+ <li>Cisco Switches/Routers/SBSC, Cisco Pix, SonicWALL, WatchGuard,
+ Barracuda, VPN (multi vendors), Gibraltar Firewall, Soho Firewall,
+ M0n0Wall (Soekris Device) (installation, configuration, maintenance,
+ and troubleshooting)</li>
+
+ <li>MS Exchange (5.5, 2000, 2005), SQL, Sendmail, Postfix, Cyrus,
+ MySQL, SpamAssasin, ClamAV (configure, maintenance, and
+ troubleshoot)</li>
+
+ <li><b>System Admin Responsibilities</b>: Created in MS/Unix/Linux
+ (AD, LDAP, and NIS) accounts and directories (email, aliases,
+ passwords, dir. Sharing/ group policies).</li>
+
+ <li>MacAfee Anti-Virus (Enterprise), Norton Anti-Virus (Enterprise),
+ Pest Patrol (Enterprise), Symantec Ghost Server (Enterprise),
+ Symantec Endpoint Protection, Barracuda Network Appliance, Untangle
+ Box</li>
+</ul>
+
+<h2>Working Experience</h2>
+
+<h3>TeamLogic IT Santa Clara (TLIT), Dec 2008 - Current</h3>
+
+<h3><i>Senior Managing Consultant</i></h3>
+
+<p>Responsible for fixing infrastructure/network/computer/phone
+issues. From simple break-fix of a computer/server (Windows, Mac,
+Linux) to installing a Cisco UC500 for a full office solution (5 - 64
+employees) (firewall/switch/router/VPN/WiFi/PBX). Administration of
+remote managed machines in addition to above mentioned tasks.</p>
+
+<h3>Abundant Life Christian Fellowship (ALCF), April 2005 - Sept
+2008</h3>
+
+<h3><i>IT Director</i></h3>
+
+<p>Responsible for all technological aspects within ALCF ($10
+million/year non-profit organization) as a manager/network
+admin/system admin. Planned, implemented, and managed 3 infrastructure
+rebuilds within as many years due to rapid growth of staff (from 32
+machines an 2 servers to 100 machines and 10 servers - site to site
+VPN and redundant network connectivity). Implemented a hybrid
+HelpDesk/Tech support utilizing staff, IT staff, consultants,
+vendors. Brought email in-house to reduce cost and increase filtering
+using Postfix, MySQL, SpamAssasin, ClamAV, and Cyrus (to setup
+administration via web). Due to rampant virus and malware issues I
+installed Symantec End Point AV and Pest Patrol, followed by a
+Barracuda Web Content Filter. Established security policies and
+procedures for internal and external network (IDS, ASA, NAC) by using
+Snort/ Acid-Base (to monitor), Barracuda WCF (to block), creating
+vlans and filtering on the Cisco Catalyst 2950 router and a Catalyst
+6509 Switch. Planned, implemented, and managed backup/disaster
+recovery solution. Managed 64 vendors.</p>
+
+<h3>Employee Benefits Specialists (EBS), October 2004 - April 2005 </h3>
+
+<h3><i>System Administrator</i></h3>
+
+<p>Responsible for the day to day operational of all networked
+systems, internal and co-located (6 servers, 48 desktops, 10 laptops,
+2 Cisco Switches, 2 co-lo servers (Citrix controlled), WatchGuard
+Firewall). Migrated mail server from Exchange 2000 to 2005. Maintain
+and oversee all security (HIPPA Standards).</p>
+
+<h3>Open Country, September 2004 - April 2005 (as Contractor)</h3>
+
+<h3><i>System/Network Administrator</i></h3>
+
+<p>Created a multi-LAN'd QA Lab with Provisioning from a central host
+machine used Shorewall to protect the intranet from the lab and the
+lab from the intranet. Setup DNS, DHCP, NFS, Samba, and printing, in
+the corporate intranet and within the lab. Setup numerous firewalls
+(Gibraltar), with VPN capabilities. Fixed Windows and Linux machines
+(hardware and software), created a /backup strategy/disaster recovery
+plan, and implemented plan with little to no down time. QA testing for
+OC Manager (OC Agent, OC Host, and OC Provisioning), on multiple
+distributions of Linux (Red Hat 7.3, 9.0, EL3; Mandrake 10; SuSE 8.2,
+9.1, SLES 8, SLES 9, JDS 2.0; Lineox; Asianux 1; Monta Vista;
+Whitebox).</p>
+
+<h3>Caminar Inc, September 2003 - June 2004 (Contractor)</h3>
+
+<h3><i>System Administrator</i></h3>
+
+<p>Troubleshooting server, desktop, and network infrastructure issues
+for a 100+ staff organization in multiple sites (10) throughout the
+Bay Area. Suggested, tested, and implemented workflow procedures,
+created documentation on all phases of work flow/troubleshooting
+procedures. Setup a number of TCO applications to administer the
+domain, setup and installed Linux Gibraltar Firewalls, and Cisco PIX
+firewalls.</p>
+
+<h3>Persistence Software Inc, September 1999 - April 2001 (employee)
+(Contractor )January 2002 - July 2003 /August 2004 - January 2005
+</h3>
+
+<h3><i>System Administrator</i></h3>
+
+<p>Provided Technical Support/System Administration which included:
+creating/deleting user accounts (Unix and Windows), trouble shooting
+problems (individual/systemic), installing MS and Unix (Sun) s/w and
+applications, upgrading o/s with latest patches, backing up servers,
+managing LDAP, installing h/w on servers (memory, hd, motherboards,
+scsi controllers, ext hd), setup VPN. Shell scripting. Backup
+Administrator, setup of environment and backup policies,
+troubleshooting, and setup and document Disaster Recovery
+procedures.</p>
+
+<h3>Netscape Communications, Mountain View, April 1996 - July 1999</h3>
+
+<h3><i>Technical Support Engineer/System Administrator</i></h3>
+
+<p>Coordinate resources between I.S. and Facilities for all project
+moves, technician for all computer and network considerations, while
+managing and balancing resources to ensure least amount of
+downtime. Developed move procedures that would result in successful
+moves (creation of shutdown scripts (VI), and trouble shooting startup
+problems), and put in place policies that ensure the continuance of
+these procedures.</p>
+
+<h3>Haralson Consulting and Design, Santa Clara, September 1992 - 1995</h3>
+
+<h3><i>Owner/Computer Technician/ Technical Sales</i></h3>
+
+<h3>LifeScan, Milpitas, May 1992 - September 1992 (Consultant)</h3>
+
+<h3><i>Desktop Technician</i></h3>
+
+<h3>Apple Computers, Cupertino, July 1991 - March 1992 (Consultant)</h3>
+
+<h3><i>Computer Technician</i></h3>
+</div>
+</div>
+</body>
+</html>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+ <title>ClearSCM: Our People: Mohammed Ansari</title>
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Article.css">
+ <link rel="stylesheet" type="text/css" media="print" href="/css/Print.css">
+ <link rel="SHORTCUT ICON" href="http://clearscm.com/favicon.ico" type="image/png">
+ <?php
+ include "../../php/clearscm.php";
+ menu_css ();
+ ?>
+</head>
+
+<body id="homepage">
+
+<?php heading ();?>
+
+<div id="page">
+ <div id="content">
+ <?php start_box ("cs2")?>
+ <h2>Mohammed Ansari</h2>
+ <p style="text-align:center">Project/Program Leader<br>
+ SCM Architect<br>
+ Configuration Management Specialist<br>
+ <a href="mymsn@hotmail.com">mymsn@hotmail.com</a>
+ <p style="text-align:center"><a href="Resume.doc">MS Word format</a></p>
+ <?php end_box ();?>
+
+<h2>OBJECTIVE</h2>
+
+<p>Hands-on <b>Project/Program Leader</b> / SCM Architec Configuration
+Management Specialist</b></p>
+
+
+<blockquote><p>Oversee, design, and provide solutions for
+implementation of configuration management, process creation and
+control, Software Quality Assurance Architecture/Framework, and to
+enhance the overall quality of software configuration and release
+control at the project, product, organization or enterprise level</p>
+</blockquote>
+
+<h2>SUMMARY</h2>
+
+<ul>
+ <li>Superior record of steady career progression <b>over 20
+ years</b> working directly with some of the <b>top IT consulting
+ firms</b> (EDS, Capgemini, and CSC) while serving some of the
+ <b>largest</b> and <b>global clients </b>(<b>US Treasury</b>,
+ <b>Fannie Mae</b>, Census Bureau, Gulfstream <b>Aerospace</b>,
+ <b>Ford</b>, GM, and <b>GMAC</b>).</li>
+
+ <li>Proficient in working with multiple <b>stake holders</b>,
+ multiple <b>vendors</b>, project resources, <b>reporting</b> to
+ sr. management, <b>gathering requirements</b>, <b>documentation</b>,
+ <b>design</b>, and presenting ideas for review/approval.</li>
+
+ <li>Proven ability to implement organizational change and manage
+ <b>enterprise</b> SCM projects working with multiple teams and
+ geographic locations.</li>
+
+ <li>Experience includes <b>management of IT</b> and <b>SCM</b>
+ projects.</li>
+
+ <li><b>Work Ethics</b> - <b>Reliable</b>, <b>persistent</b>, and
+ <b>hard working</b> to ensure project <b>success</b>. Take pride in
+ designing and implementing SCM solutions. <b>Passionate</b> about
+ implementing <b>the best practical solutions</b> to meet the
+ <b>organizational goals</b> while providing the highest <b>ROI</b>.
+ Always in-tuned in paying attention to the client, promptly acting
+ upon the direction from the senior management, and in building
+ lasting relationships with co-workers and project teams.</li>
+
+ <li><b>SDLC</b> - Practical experience and in-depth knowledge of
+ SDLC gained while supporting multiple software development projects
+ for multiple clients in various roles (<b>QA</b>,<b> Software
+ Programmer</b>, <b>Technical Leadership</b>, <b>Management</b>,
+ <b>SCM Solution Design</b> and <b>Implementation</b>). Hands-on
+ experience in <b>Architecting</b>, Designing, Developing data driven
+ applications using <b>C/C++ </b>and <b>Java</b> programming
+ languages.</li>
+
+ <li><b>SCM</b> - <b>Over 11 years of experience</b> in designing and
+ implementing <b>SCM</b> Solutions. Assessing as-is environments and
+ implementing practical solutions to meet organizational
+ needs. Expert knowledge of Source Code Control, Branching, SW
+ Integration, Baselines, CM Audits, <b>Change</b>, <b>Defect</b>,
+ <b>Build</b>, <b>Release</b>, and <b>Configuration Management
+ </b>practice. Hands-on experience with <b>ClearCase</b>,
+ <b>ClearQuest</b>, <b>PVCS</b>, <b>VM</b>, <b>Dimensions</b>,
+ <b>SVN</b>, <b>CVS</b>, <b>Remedy</b>, Mercury, and additional SCM
+ tools.</li>
+
+ <li><b>Best Practices</b> - Experienced in Implementing SCM
+ Solutions while utilizing SDLC, <b>CMMi</b>, <b>ITIL</b>,
+ <b>ISO900</b>, <b>SEI</b>, and <b>IEEE</b> best practices.</li>
+
+ <li><b>QA</b> - Over 5 years of hands-on experience working as a
+ <b>Quality Control Analyst</b>. Developed test plans and test cases
+ for C/C++, and Java applications running on Windows, UNIX, and
+ Mainframe environments. Utilized testing tools for debugging
+ and generation of Metrics. </li>
+
+ <li><b>Databases</b> - Thorough knowledge of <b>relational
+ databases</b>, <b>architecture</b>, <b>SQL</b>, <b>PL/SQL</b>,
+ <b>schemas</b> and hands-on experience in working with
+ <b>Oracle</b>, <b>SQL</b> <b>Server</b>, Sybase, DB2, Ingress, and
+ Access database.</li>
+
+ <li><b>OS/Platforms </b>- Extensive experience with all
+ major <b>UNIX</b> (Solaris, HP-UX, IRIX, AIX), <b>Linux</b>, and
+ <b>Windows </b>Platforms (NT, 2000/2003, XP, Vista, Windows 7),
+ including some experience with <b>Mainframe</b>.</li>
+
+ <li><b>Automation tools</b>- Proficient in design, development, and
+ implementation of SCM automation tools and scripts within SDLC and
+ Agile environments.</li>
+</ul>
+
+<table align="center" border="1" cellpadding="7" cellspacing="0">
+ <tr>
+ <th bgcolor="#e5e5e5" colspan="2">TECHNICAL SKILLS</td>
+ </tr>
+ <tr>
+ <th bgcolor="#d9d9d9">AREA</td>
+ <th bgcolor="#d9d9d9">TECHNOLOGY</td>
+ </tr>
+ <tr>
+ <th align="left">OS</th> <td>NT, <b>Windows</b> 2000/2003, XP,
+ <b>Unix</b> (Sun Solaris, HP-UX, AIX), Linux (RedHat), MF</td>
+ </tr>
+ <tr>
+ <th align="left" bgcolor="#f3f3f3">Version Control</th>
+ <td bgcolor="#f3f3f3"><b>CVS</b>, Subversion (<b>SVN</b>),
+ <b>ClearCase</b>, <b>PVCS</b>, <b>VM</b>, <b>Dimensions</b>,
+ Harvest</td>
+ </tr>
+ <tr>
+ <th align="left">Build & Integration</th>
+ <td><b>make</b>, <b>ant</b>, <b>build forge</b></td>
+ </tr>
+ <tr>
+ <th align="left" bgcolor="#f3f3f3"><b>App/Web Servers</b></th>
+ <td bgcolor="#f3f3f3">IIS, <b>Apache</b>, IBM <b>Websphere</b></td>
+ </tr>
+ <tr>
+ <th>Languages & Scripting</th>
+ <td><b>C, C++, Java/J2EE,</b> VB, SQL, .NET, Ant, UNIX Shell (bsh/ksh/csh/tcsh), Perl, Python</td>
+ </tr>
+ <tr>
+ <th bgcolor="#f3f3f3">Defect Tracking Tools</th>
+ <td bgcolor="#f3f3f3"><b>ClearQuest</b>, Team Track, Remedy, <b>Mercury</b></td>
+ </tr>
+ <tr>
+ <th>Database</th>
+ <td><b>Oracle</b>, Sybase, DB2, MS SQL Server, MS Access, MySQL</td>
+ </tr>
+ <tr>
+ <th bgcolor="#f3f3f3">Methodologies</th>
+ <td bgcolor="#f3f3f3"><b>SDLC</b>, <b>RAD</b>, <b>Agile</b>, <b>Scrum</b>, <b>RUP</b>, Waterfall</td>
+ </tr>
+ <tr>
+ <th>Best Practices</th>
+ <td><b>ITIL</b>, <b>CMMI Level 5</b>, ISO9000, SEI, IEEE</td>
+ </tr>
+ <tr>
+ <th>Miscellaneous Tools</th>
+ <td><b>Visio</b>, <b>MS Office Suite</b>, <b>MS Project</b>, Clarity, <b>Business Objects</b>, <b>Micro Strategy</b></td>
+ </tr>
+</table>
+
+<h2>CERTIFICATION & TRAINING</h2>
+
+<ul>
+ <li>Borland <b>Requirements Management</b> Essential Training (2003)</li>
+
+ <li><b>Project Management</b> Training by Keane Consulting Inc. (2002)</li>
+
+ <li><b>Systems Engineering & Systems Analyst</b> Training by EDS
+ (1996 - 1998</li>
+
+ <li><b>Oracle & PL/SQL</b> Training by Oracle (2002)</li>
+
+
+ <li><b>Java Object Oriented Programming</b> Training by Sun
+ Microsystem (2001)</li>
+
+ <li><b>SAP Document Management</b> Training by SAP (2001)</li>
+
+ <li><b>ClearCase</b> Training by Rational (2001)</li>
+
+ <li><b>Dale Carnegie</b> Relationship Management Training by Dale
+ Carnegie Institute (1991)</li>
+
+ <li><b>CMMi</b> Training (level 3 - 5 environments) provided by EDS
+ and Keane Inc. (1996 - 2003)</li>
+</ul>
+
+<h2>PROFESSIONAL EXPERIENCE</h2>
+
+<h3>Enterprise SCM Architect (08/10 - 10/10)</h3>
+
+<p>Independent Contractor Client - <b>Fannie Mae</b>, Herndon, VA</p>
+
+<ul>
+ <li>Note that his assignment was shortened due to unexpected budget
+ cuts. Will provide excellent internal references from Fannie
+ Mae.</li>
+
+ <li>Worked as an <b>Enterprise SCM Architect</b> and <b>Process
+ Lead</b>. Was responsible of Process Engineering and Operational
+ Support as listed below.</li>
+
+
+ <li><b>PROCESS ENGINEERING</b>: Establish, document, and sustain
+ standardized change management processes specific to business
+ requirements, application defects, and application
+ enhancements. Train, facilitate implementation, and standardized
+ these processes across Fannie Mae enterprise.</li>
+
+ <li><b>LIASON and COORDINATION SUPPORT</b>: Based on defined
+ requirements, create / manage change requests. Schedule the change
+ based on project goals i.e. emergency fix, risk minimization, or
+ resources. Monitor approval of the requests and facilitate as
+ needed. Shakeout or test changes prior to turnover.</li>
+
+ <li><b>OPERATIONAL SUPPORT</b>: Perform tool administration for
+ Rational <b>RequisitePro</b>, <b>ClearQuest</b> and
+ <b>ClearCase</b>. Analyze and provide problem resolution on
+ technical issues. Identify potential improvements to increase the
+ <b>reliability</b>, <b>availability</b>, <b>support</b>, and
+ <b>performance</b> of the applications and infrastructure. Interface
+ with developers, test users; <b>communicate</b> with
+ <b>technical</b>, <b>management</b>, and <b>external</b>
+ <b>teams</b> to identify and <b>resolve</b> <b>problems</b>.</li>
+
+ <li><b>ROOT CAUSE ANALYSIS</b>: Investigate problems to determine
+ their root cause, including conducting research, interviews, and
+ evidence gathering; and writing reports of findings, conclusions,
+ and recommendations for subsequent actions.</li>
+
+ <li><b>COLLABORATION</b>: Collaborate with Quality and Process
+ Management architects to develop, maintain and improve <b>process
+ automation</b>, <b>monitoring</b>, and <b>reporting</b>
+ tools. Collaborate with application and infrastructure architects
+ and developers to maintain and improve the overall performance,
+ reliability, scalability, supportability of the application and
+ infrastructure.</li>
+</ul>
+
+<h3>Lead SCM Specialist (03/10 - 08/10)</h3>
+
+<p><u>ICS</u>, Client - Department of Commerce (<b>Census Bureau</b>), Suitland, MD</p>
+
+<ul>
+ <li>Joined ICS at the peak of 2010 Census to evaluate and streamline
+ SCM processes.</li>
+
+ <li>Accessed existing processes to eliminate inefficiencies and
+ non-compliance. Provided recommendations and implemented solutions
+ to enhance and streamline SCM processes.</li>
+
+ <li>Designed and Implemented defect tracking process utilizing
+ existing licenses of HP Mercury.</li>
+
+ <li><b>Automated</b> and <b>streamlinedbuild</b> process with
+ <b>SVN</b> and <b>ANT</b>. Implemented <b>Agile Continuous
+ Integration</b> process to automate <b>daily builds</b>,
+ <b>releases</b>, and <b>deployments</b>. Kept <b>100+</b> resources
+ (Developers, DBS, Testers, and Operational Support personal)
+ informed regarding the build, release and deployment schedules.</li>
+
+ <li><b>Enhanced processes</b> for making (<b>DDL, DML, </b>and
+ <b>DCL</b>) changes to <b>Oracle</b> (test, beta, and production)
+ databases.</li>
+
+ <li>Implemented scripts to perform <b>smoke test</b> after each
+ deployment.</li>
+
+ <li><b>Chaired and facilitated</b> the <b>daily Architectural Review
+ Board</b> (ARB) and <b>Change Control Board </b>(CCB)
+ <b>meetings</b>.</li>
+
+ <li>Responded to <b>audit</b> requests and worked with the auditors
+ to ensure <b>compliance</b>.</li>
+
+ <li>Implemented <b>scripts</b> to <b>continually monitor QA, BETA,
+ PRF,</b> and <b>PROD environments</b>.</li>
+
+ <li>Implemented <b>scripts</b> to send <b>alerts</b> in the event of
+ <b>performance degradation or failure</b>.</li>
+
+ <li>Provided SCM support and training for new resources joining the
+ team.</li>
+
+ <li>Implemented application <b>versioning scheme</b>.</li>
+</ul>
+
+
+<h3>Sr. SCM Architect/Process Lead (07/09 - 03/10)</h3>
+
+<p>AlonInc, Client - <b>US Treasury</b> (Office of the Comptroller of the Currency), Washington, DC</p>
+
+<ul>
+ <li>Worked as a <b>SCM</b> <b>Enterprise Process Architect</b> and
+ <b>Process Lead</b>. Responsible of <b>reviewing</b>,
+ <b>designing</b>, <b>enhancing</b>, and <b>controlling</b> <b>SCM
+ processes</b> at the <b>enterprise</b> <b>level</b>.</li>
+
+ <li>Responsible of <b>communicating</b>, <b>documenting</b>, and
+ <b>implementing CM policies</b>.</li>
+
+ <li>Responsible of <b>evaluating existing SCM process</b> and
+ <b>tools</b>, working with the <b>SCM</b> <b>tool</b> <b>vendors</b>
+ and <b>suppliers</b> to <b>evaluate</b> <b>SCM tools</b> and to
+ determine the <b>best fit</b>, provided recommendations to
+ streamline SCM processes at enterprise level to reduce service
+ disruptions and downtime for the user base consisting of
+ <b>4000+</b> user.</li>
+
+ <li>Responsible of providing recommending and designing <b>new
+ processes</b>, presenting new ideas to the sr. management, receiving
+ authorizations to implement, enhancing existing processes,
+ <b>updating SCM plans, procedures, flowcharts</b>, and
+ <b>documents</b>.</li>
+
+ <li><b>Provided training</b> to the user base in using new tools and
+ processes (PMs, SW Developers, DBAs, and IT Operational Support
+ Personal).</li>
+
+ <li>Provided a <b>complete set of requirements</b> to implement a
+ new <b>defect tracking system</b> using <b>ClearQuest</b>. This has
+ been designed, developed, implemented, and currently being used at
+ the OCC as an <b>enterprise defect management system</b>.</li>
+
+ <li>Provided requirements and recommendations for implementing
+ <b>CMDB</b>.</li>
+
+ <li>Implemented <b>processes for conducting SCM audits</b> within
+ the OCC environment.</li>
+
+ <li>Implemented <b>versioning scheme</b> for major, minor, and
+ emergency releases.</li>
+
+ <li>Implemented requirements for back-out procedures.</li>
+
+ <li>Participated in <b>CCBs</b>, assessed risk for various
+ implementation plans, participated <b>in release schedule
+ </b>meeting, reviewed <b>communication</b> and <b>deployment
+ plans</b>, and provided weekly <b>release readiness status</b> to
+ the sr. management.</li>
+
+ <li>Implemented processes surrounding the use of CM tools
+ (<b>ClearCase</b>, <b>VM</b>, <b>PVCS</b>) in <b>branching</b>,
+ <b>merging</b>, <b>promoting</b> code through various lifecycle
+ stages (development, testing, and production), locking source code,
+ and creating <b>baselines</b>.</li>
+</ul>
+
+<h3>Sr. Software Configuration, Change, and Release Manager (06/08 - 05/09)</h3>
+
+<p><U>Independent Consulting</U>, Client - Intelizign, Bloomfield Hills, MI</p>
+
+<ul>
+ <li>Designed and implemented an <b>end-to-end Configuration
+ Management Plan </b>for 80+ member team with a highly automated
+ build and deploy process on UNIX platforms.</li>
+
+ <li>Implemented <b>branching scheme</b> for <b>parallel
+ development</b>, <b>merging</b>, and <b>code integration</b>.</li>
+
+ <li>Implemented a <b>web based defect tracking system</b> accessible
+ 24x7 in the United States and India.</li>
+
+ <li>Performed daily <b>configuration</b>, <b>change</b>,
+ <b>build</b>, and <b>deployment</b> activities.</li>
+
+ <li>Chaired and facilitated CCB meetings.</li>
+
+ <li>Managed <b>test, beta, and production environments</b>.</li>
+</ul>
+
+<h3>SCM Architect and Process Lead (10/06 - 06/08)<U>Capgemini</U>,
+Client - General Motors, Southfield, MI</h3>
+
+<ul>
+ <li>Worked as an <b>Architect</b> and <b>Process Lead</b>
+ responsible of <b>overseeing</b> the SCM activities for two separate
+ teams (software development, software maintenance/support)
+ consisting of <b>over 350 resources</b> located in <b>four
+ geographical regions</b> (Michigan, Chicago, Canada, and
+ India).</li>
+
+ <li>Gathered corporate requirements from the project office, and project requirements from the stake holders to conduct initial assessment.</li>
+
+ <li>Manage a geographically dispersed release management team
+ consisting of nine CMs.</li>
+
+ <li><b>Planned</b>, <b>defined</b>, <b>received approvals</b>, and
+ <b>implemented</b> the following <b>CM processes</b> and
+ <b>tools</b> in support of <b>GM initiatives</b> at the Capgemini
+ development center.</li>
+
+ <ul>
+ <li><b>SW Development Process</b> based on <b>SDLC</b> along with
+ a <b>fully automated integration</b>, <b>build</b>, and
+ <b>deployment</b> process to (test, beta, performance, and
+ production) environments.</li>
+
+ <li>Configuration Management Process utilizing <b>SVN</b> and
+ <b>VM</b></li>
+
+
+ <li>Sharing of test and development environments by the
+ development, QA, and the support team.</li>
+ </ul>
+
+ <li><b>Implemented processes</b> and <b>created plans</b> to
+ <b>consolidate</b> <b>code</b> into a <b>single repository</b> for
+ <b>over 150 applications</b>. The source code was initially
+ scattered over at multiple vendor sites in various geographical
+ locations. Identified and worked with the SCM Leads for each of the
+ applications to track, transfer, and integrate code into a single
+ repository.</li>
+
+ <li><b>Provided</b> <b>SCM training</b> to create
+ <b>awareness</b>and to <b>insure compliance</b> with the <b>SCM
+ policies</b> and <b>procedures</b>.</li>
+
+ <li>Participated in <b>CCBs</b>and <b>release planning meetings</b>.</li>
+
+ <li><b>Conducted SCM audits</b> on <b>high visibility projects</b>
+ to <b>verify compliance</b>. Provided <b>audit reports</b> to the
+ stake holders.</li>
+</ul>
+
+<p><u>Capgemini</u>, Client - MDS Pharmaceuticals, Dallas, Tx</p>
+
+<ul>
+ <li>Implemented a <b>complete IT Asset Management solution</b> for
+ MDS Pharmaceuticals based on <b>CMDB</b> within an <b>ITIL</b> and
+ <b>FDA</b> <b>regulated</b> environment.</li>
+
+ <li>The complete solution was implemented in three phases.</li>
+
+ <ul>
+ <li><b>Requirements gathering</b> (detailed information on CIs and
+ attributes to be captured, maintained over its lifespan, and
+ retired).</li>
+
+ <li><b>Architecture, design, and implementation</b> of <b>CMDB</b>
+ and <b>auto-discovery</b> tools.</li>
+
+ <li>Implementation of <b>tools</b>, <b>training, </b>and <b>work
+ methods </b>to analyze and reconcile the differences between the
+ CMDB and the data collected by the auto-discovery
+ tools. Implementation also included <b>CMDB Audit Plan</b>,
+ <b>Physical Inventory Audits Plan</b>, <b>Missing Data Work
+ Instructions</b> (WI), <b>Data Normalization</b> WI, <b>Processing
+ Duplicate CIs</b>, setting up templates along with the routing and
+ approval process to capture approvals prior to adding new CIs and
+ making changes to existing CIs, and more.</li>
+
+ </ul>
+
+ <li>This project was administered and managed from the Capgemini
+ Data Center located in Dallas.</li>
+
+ <li>The project was implemented at an enterprise level and comprised
+ of over 6000 CIs located at multiple facilities in Canada.</li>
+</ul>
+
+<h3>Software Development Manager (11/05 - 10/06) <u>CSC</u>, Client -
+GD Gulfstream Aerospace Corporation, Savannah, GA</h3>
+
+<ul>
+ <li>Worked as a <b>SW Development Manager</b> managing <b>multiple
+ projects</b> within the VIPER portfolio of <b>Client/Server</b> and
+ <b>Web</b> based Applications. These applications were developed in
+ .<b>Net</b> using C#, VB, and ASP programming with <b>SQL Server</b>
+ backend.</li>
+
+ <li>Responsible of client interface in managing daily activities,
+ interfacing <b>lead engineers</b> of various <b>engineering
+ disciplines</b> to <b>design</b>, <b>enhance</b>, and
+ <b>re-engineer</b> <b>PLM/PDM</b> <b>process</b> in Enovia/LCA
+ environment.</li>
+
+ <li>Responsibilities included <b>managing a team of BAs, Architects,
+ DBAs, Programmers, Testers, Administrators, and Network
+ Engineers</b> to build, integrate, test, and <b>deploy 3-tier
+ solutions</b>.</li>
+
+ <li>Provided direction to Configuration Managers in streamlining SCM
+ processes, ensuring proper baselines are created and maintained,
+ integrating, and managing source code received from multiple project
+ resources and vendors (IBM, Axiom, Dassault, and Insight) in the
+ Harvest repository.</li>
+</ul>
+
+<h3>Software Development Manager (05/04 - 07/05)<u>Keane Consulting
+Inc.</u>, Client - General Motors Acceptance Corp. (GMAC), Southfield,
+MI</h3>
+
+<ul>
+ <li><b>Managed</b> a <b>development</b> portfolio of PC-Fast/OSCAR
+ applications</P> <li><b>Managed </b>a team of <b>on-shore </b>and
+ <b>near-shore (</b>Canadian team) of technical resources
+ (programmers, analysts, & DBAs).</li>
+
+ <li>Acted as a conduit through which all work request and new
+ requirements were channeled, assigned, monitored, and approved.</li>
+
+ <li>Ensured all PC-Fast source code and artifacts were properly
+ tracked and promoted in the PVCS repository.</li>
+
+ <li>In-charge of ensuring adhering to the <b>CMMi level 5</b>
+ processes.</li>
+
+ <li>In-charge of ensuring all documents were up-to-date, approved,
+ signed-off, and properly tracked.</li>
+
+ <li>Performed <b>Release Management</b> activities utilizing
+ <b>CVS</b> repository for the OSCAR application.</li>
+
+ <li>OSCAR application was developed in <b>Java/J2EE</b>, on a
+ <b>Websphere </b>platform in a <b>UNIX</b> environment.</li>
+
+ <li>OSCAR application also utilized <b>server clusters</b> for
+ <b>load balancing</b> and <b>failover capabilities</b>. Whereas
+ PC-Fast portfolio contained a set of <b>client/server</b>
+ applications that were developed using <b>VB/VBA</b> with <b>SQL
+ Server</b> backend.</li>
+
+ <li>Administered <b>CVS</b> repository and users on a <b>Linux</b>
+ platform to manage OSCAR source code.</P> <li>Wrote <b>step-by-step
+ deployment instructions</b> for IBM resources that controlled the
+ production environment. The instructions included:
+
+ <ul>
+ <li>Configuration changes to the production environment.</P>
+ <li>Deployment of Java/J2EE code on Websphere platform.</li>
+
+ <li>DDL, DML, and DCL changes to the Oracle database.</li>
+ </ul>
+
+ <li>Conducted Release Readiness reviews.</li>
+
+ <li><b>Coordinated</b> <b>nightly deployments</b> requiring
+ <b>Keane</b>, <b>IBM</b>, and <b>HP resources</b>.</li>
+</ul>
+
+<h3>Configuration/Release Manager/PDM Metaphase Administrator (03/99 - 05/04) <u>Keane Consulting Inc.</u>, Client - Ford Motors, Dearborn, MI</h3>
+
+<ul>
+ <li>Worked as a <b>dedicated</b> and <b>people-oriented</b>
+ Metaphase <b>Administrator</b> with a positive attitude.</li>
+
+ <li><b>Administered</b> Metaphase application on the <b>distributed
+ UNIX platforms</b>.</li>
+
+ <li><b>Configured</b>, <b>Administered</b>, and <b>Managed</b>
+ <b>R&D, test, integration, and training environments</b>.</li>
+
+ <li>Implemented Metaphase patches, updates, and new releases.</li>
+
+ <li>With every new Metaphase release, identified deprecated APIs in
+ the customized Metaphase code.</li>
+
+ <li>Notified project teams to update customizations by removing
+ deprecated code.</li>
+
+ <li>Worked as a <b>gatekeeper</b> and as a configuration manager in
+ a multi-vendor environment to <b>receive</b>, <b>integrate</b>,
+ <b>manage</b>, and <b>build</b> customized <b>code</b>. Vendors were
+ located at various facilities within the United States, Germany, and
+ India.</li>
+
+ <li>Build and deploy <b>C/C++</b> and <b>Java</b> code on the
+ <b>UNIX</b> platforms (HP-UX, AIX, and Solaris).</li>
+
+ <li>Streamlined build and deployment process using <b>makefiles</b>,
+ <b>Perl</b>, and <b>UNIX</b> <b>scripts</b>.</li>
+
+ <li>Created cron jobs and wrote Perl, UNIX, and <b>SQL scripts</b>
+ to <b>automate</b> <b>maintenance</b> and <b>monitoring</b> of
+ multiple environments.</li>
+
+ <li><b>Maintained</b> and <b>updated</b> backend<b> Oracle databases</b>.</li>
+
+ <li><b>Created scripts</b> to <b>continually</b> <b>monitor</b> and
+ <b>alert</b> on-call support personal when <b>issues</b> were
+ <b>detected</b>.</li>
+
+ <li>Managed <b>ClearCase</b> <b>VOBS</b>, created <b>branches</b>
+ for <b>parallel</b> <b>development</b>, setup standard ClearCase
+ <b>views</b> to <b>integrate</b> and <b>build</b> code.</li>
+
+ <li>Issued and tracked ClearCase branches to the project teams and
+ vendors.</li>
+
+ <li>Created <b>naming</b> and <b>numbering</b> <b>schemes</b> for
+ <b>major</b>, <b>minor</b>, and <b>emergency</b> release.</li>
+
+ <li>Worked with <b>multiple vendors</b> and <b>project teams</b> to
+ <b>diagnose</b> and <b>resolve build issues</b>.</li>
+</ul>
+
+<h3>C/C++ Programmer/Configuration Manager (07/95 - 02/99) <u>EDS</u>, Client - General Motors, Warren, MI</h3>
+
+<ul>
+ <li>Under the guidance of the Senior Unigraphics development team,
+ designed, enhanced, and customized the Unigraphics code on
+ <b>UNIX</b> platforms (Sun and HP) using <b>C/C++</b> programming
+ language.</li>
+
+ <li>Customized Unigraphics code for the CAD designers to by
+ automating the manual time consuming tasks.</li>
+
+ <li>Reduced design time for repetitive manual tasks through
+ customization and automation from weeks to hours.</li>
+
+ <li>Participated in and facilitated <b>code reviews</b>. As a
+ facilitator ensured all of the changes identified during the code
+ review are correctly updated and checked-in to the SCM
+ repository.</li>
+
+ <li>Played a key role as a configuration and release manager for
+ this project.</li>
+
+ <li>Implemented proprietary EDS configuration management tools on
+ the UNIX platforms.</li>
+
+ <li>Implemented <b>version numbering</b> scheme.</li>
+
+ <li>Created <b>makefiles</b> to <b>streamline</b> the <b>build
+ process</b>.</li>
+
+ <li>Created <b>UNIX scripts</b> to <b>track</b>, <b>package</b>, and
+ <b>deploy</b> correct versions of the code at various vendor
+ sites. Each vendor had a unique environment which required proper
+ versions to be installed.</li>
+
+ <li>Created UNIX scripts to baseline, package, archive, and extract
+ proper versions from the archives.</li>
+
+ <li>Maintained compliance with the ISO 9000 best practices and
+ requirements.</li>
+
+ <li>Helped the organization and the project team in strictly
+ adhering to CMMi Level 3 guidelines and in achieving CMMi Level 3
+ certification.</li>
+</ul>
+
+
+<h3>QA/Test Engineer (1989 - 1995) <u>ICI</u>, Client - Ford Motors,
+Dearborn, MI</h3>
+
+<ul>
+ <li>Developed test design and test plan documents for the SBDS
+ Diagnostic System Software.</li>
+
+ <li>Created test cases to test each of the SBDS diagnostic
+ routines.</li>
+
+ <li>Worked with the QA team to identify bugs and log issues.</li>
+
+ <li>Worked with the Software Development team and the Automotive
+ Engineers to resolve the identified issues.</li>
+</ul>
+
+<h2>Association Memberships</h2>
+
+<ul>
+ <li>Capgemini Global</li>
+
+ <li>North America Big 5 Consultants</li>
+</ul>
+
+<h2>Education</h2>
+
+<p><b>Anwar-Ul-Uloom College, Hyderabad, India</b></p>
+
+<p>Pre-Engineering with emphasis on (Math, Physics, and Chemistry),
+completed (1980 to 1982)</p>
+
+<p><b>Oakland Community College,</b> Auburn Heights, MI</p>
+
+<p>Automobile Technology Program, completed with GPA 3.8/4.0 (1986 to
+1988)</p>
+
+<p><b>Electronic Data Systems,</b> Southfield, MI</p>
+
+<p>EDS Core IT Systems Engineering Program, completed & ranked top 3% of the
+class (1996 - 1998)</p>
+
+<p>With emphasis on Software Development, Process Analysis &
+Design, Relational Databases, and Quality Control</p>
+
+<p><b>Lawrence Technological University, </b>Southfield, MI</p>
+
+<p>Mechanical Engineering, fourth year incomplete. (1989 to 1993)</p>
+
+<h2>References</h2>
+
+<p>Available upon request</p>
+</div>
+</div>
+</body>
+</html>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+ <title>ClearSCM: Our People: Ron Van Scherpe - Associate</title>
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Article.css">
+ <link rel="stylesheet" type="text/css" media="print" href="/css/Print.css">
+ <link rel="SHORTCUT ICON" href="http://clearscm.com/favicon.ico" type="image/png">
+ <?php
+ include "../../php/clearscm.php";
+ menu_css ();
+ ?>
+</head>
+
+<body id="homepage">
+
+<?php heading ();?>
+
+<div id="page">
+ <div id="content">
+ <?php start_box ("cs2")?>
+ <h2><a href="http://penwin.net">Ron Van Scherpe</a></h2>
+ <p style="text-align:center">1225 Vienna Drive #157<br>
+ Sunnyvale, California 94089<br>
+ (650) 722-0759<br>
+ Email: <a href="mailto:rvanscherpe@gmail.com">rvanscherpe@gmail.com</a>
+
+ <p style="text-align:center"><a href="Resume.doc">MS Word format</a></p>
+
+ <?php end_box ();?>
+
+ <h2>Objective</h2>
+
+ <p>To obtain a Systems/Network Administration position, in a mixed
+ operating system environment.</p>
+
+ <h2>Summary of Qualifications</h2>
+
+ <ul>
+ <li>9 Years of System Administration in a mixed computing
+ environment: Unix & 2000</li>
+
+ <li>12+ years of work experience in Silicon Valley in a variety of
+ different positions.</li>
+
+ <li>Excellent working knowledge of the following Microsoft Windows
+ operating systems: Windows 95, 98, NT, 2000 and XP.</li>
+
+ <li>Hands on work experience with the following Linux
+ distributions: Red Hat, Mandrake and SuSE.</li>
+
+ <li>Ability to compile Linux sources and kernel.</li>
+
+ <li>Working knowledge of Solaris 6 and 7.</li>
+
+ <li>Hands on experience with the following Linux/Unix desktops:
+ KDE and Gnome.</li>
+
+ <li>Practical knowledge of Microsoft Windows technologies such as:
+ Active Directory, Domain Controllers, Global Catalog and
+ Bridge-head Servers.</li>
+
+ <li>Understanding knowledge of networking protocols and
+ applications: WINS, TCP/IP, 802.11b wireless, DHCP, DNS, SAMBA,
+ NIS and NFS.</li>
+
+ <li>Familiar with Cisco 2500 routers, Intel & Dell layer 3,
+ Packeteers, Sonicwall and Netscreen firewalls and Juniper
+ Network's SA-1000 VPN.</li>
+
+ <li>Experience with HTML and various UNIX shells.</li>
+
+ <li>Familiar with the following internet applications: Apache and
+ PHP.</li>
+
+ <li>Familiar with the following open source CMS: Mambo, Drupal,
+ Xoops!</li>
+
+ <li>Working knowledge of network monitoring tools: Nagios &
+ MRTG</li>
+
+ <li>Hands on experience with the following Windows tools: Veritas
+ Backup Exec, Norton Anti-virus Enterprise Edition, Cygwin,
+ Lanware's NMS Console, Terminal Services, Remote Desktop and
+ Visio.</li>
+
+ <li>Familiar with PC (IBM e335 servers, Dell 1850s, 2650s, 2850s)
+ and Sun (Ultra 5, Utlra 10, Ultra 80 & Ultra 450 Sunfire210)
+ hardware as well as Network Appliance and EMC filers.</li>
+
+ <li>Familiar with Inter-Tel PBX systems.</li>
+
+ <li>Understanding knowledge of T-1's voice T-1's, Frame-Relay and
+ DSL connections.</li>
+
+ <li>Excellent communication skills, working with all levels of
+ upper management including VP's and CEO</li>
+
+ <li>Experience in working in start-up environments.</li>
+ </ul>
+
+ <h2>Experience</h2>
+
+ <h3>Penwin Solutions, Sunnyvale, CA President & CEO</h3>
+
+ <p>04-present</p>
+
+ <ul>
+ <li>Formed a consulting business in 04 which specialized in
+ Windows and Linux environments.</li>
+
+ <li>Contracted with Salira Optical Networks to maintain their
+ network, server and desktop infrastructure. Also installed an
+ Exchange 2003 server and migrated users mailbox from Exchange 2000
+ to the new 2003 server./li>
+
+ <li>Worked with a variety of home users and small business.</li>
+
+ <li>Was a member of the Mountain View Chamber of Commerce.</li>
+ </ul>
+
+ <hr noshade>
+
+ <h3>Silicon Optix, San Jose, CA, Network Administrator</h3>
+
+ <p>04-present</p>
+
+ <ul>
+ <li>One of 5 Network Administrators which spanned across multiple
+ sites, San Jose, Orlando, Toronto and Hannover.</li>
+
+ <li>Main support for headquarters in San Jose supporting 25
+ end-users which were mostly Execs including the CEO.</li>
+
+ <li>Supported remote users, sales and executives along with
+ individuals in our Shanghai and Taiwan offices.</li>
+
+ <li>Responsible for purchasing all new hardware and software for
+ site. Worked with a variety of vendors to get the best deal.</li>
+
+ <li>Planned and implemented a Exchange 2003 upgrade which
+ consisted of upgrading Active Directory and removing Active
+ Directory Connectors prior to the upgrade due to previous Exchange
+ 5.5 servers. Was the first of 3 sites to perform the
+ upgrade.</li>
+
+ <li>Installed and configured a server to run ClearCase.</li>
+
+ <li>Installed and configured a second Domain Controller for
+ site.</li>
+
+ <li>Cleaned up and organized server room by purchasing a server
+ cabinet and installing all servers in it.</li>
+
+ <li>Installed a EMC2 SAN solution to replace a Dell PowerVault NAS
+ box.</li>
+
+ <li>Was responsible for facilities, by making sure a card access
+ system was installed.</li>
+
+ <li>Researched, priced, and implemented a web based Enterprise
+ helpdesk and asset manager application, so that end users could
+ submit trouble tickets and keep track of progress.</li>
+
+ <li>Deployed Nagios and MRTG to monitor network and server
+ outages.</li>
+
+ <li>Installed WSUS server which provided automatic Microsoft
+ updates to desktop and laptops.</li>
+
+ <li>Revamped backup strategy by moving from 3 separate backup
+ servers to one and installing clients on all other servers.</li>
+ </ul>
+
+ <hr noshade>
+
+ <h3>LinkIT, Portland, OR, Contractor</h3>
+
+ <p>04-04</p>
+
+ <ul>
+ <li>Hired on as a contractor to install and configure 8 Solaris
+ servers for training department for a client of LinkIT, Credence,
+ in Milpitas.</li>
+
+ <li>Helped in the transitioning and cleanup of LDAP services</li>
+
+ <li>Participated, as a team member, in implementing new networking
+ hardware throughout the Corporate Enterprise.</li>
+ </ul>
+
+ <hr noshade>
+
+ <h3>Salira Optical Networks, Santa Clara, CA, IT Manager</h3>
+
+ <p>01-04</p>
+
+ <ul>
+ <li>IT Manager for a world-wide company residing in Santa Clara,
+ CA. and Shanghai, China, which consisted of a Windows 2000
+ infrastructure, 80 users, 2 sites (Santa Clara & Shanghai), 150
+ desktops running Windows NT 4.0, 2000, XP and 8 Windows 2000
+ servers.</li>
+
+ <li>Primary duties included: phone system administration, network
+ administration, server administration and desktop administration,
+ building security administration, 24 Hour on call support and
+ facilities management.</li>
+
+ <li>Designed and implemented a Windows 2000 Active Directory
+ infrastructure which connected two sites(Santa Clara, CA and
+ Shanghai, China)</li>
+
+ <li>Traveled to Shanghai where I installed a Windows 2000
+ infrastructure, which consisted of a Domain Controller, Exchange
+ and ClearCase servers, Intel routers and switches as well as a
+ Sonicwall firewall, which connected the two sites together via a
+ secure VPN tunnel.</li>
+
+ <li>Managed and guided system administrator in Shanghai
+ office.</li>
+
+ <li>Installed and managed dual Exchange 2000 servers (Santa Clara
+ and Shanghai).</li>
+
+ <li>Implemented Microsoft's RAS server so that remote users could
+ connect to the corporate network.</li>
+
+ <li>Designed and configured multiple LANS using layer 3 switches
+ which allowed for VLANs. </li>
+
+ <li>Recovered from a devastating network disaster by replacing the
+ core layer3 switch, which went bad, with a Linux box and 2 quad
+ Ethernet cards.</li>
+
+ <li>Responsible for purchasing all IT capital equipment and
+ Software and vendor relations.</li>
+
+ <li>Managed the planning and implementation of a company move,
+ twice, (phones, T-1s, network, servers, desktops, labs, etc.) to
+ new facilities, which consisted of managing outside consultants
+ and contractors.</li>
+
+ <li>Planned and managed the upgrade of corporate PBX, which also
+ consisted of the installation of a voice T-1 and DIDS.</li>
+
+ <li>Implemented a centralized corporate anti-virus software
+ solution to protect all desktops and servers from viruses.</li>
+
+ <li>Maintained and rolled out service paks across all desktops and
+ servers.</li>
+
+ <li>Wrote a corporate IT Policy explaining various functions of IT
+ and how it works to protect and serve the company.</li>
+
+ <li>Proactively monitored a variety networking resources and
+ servers, using such tools as Lanware's NMS console, which provides
+ monitoring of Windows 2000 performance counters and application
+ services</li>
+
+ <li>Worked with the Software Test Engineering team to help
+ troubleshoot network problems related to the company's
+ product. </li>
+
+ <li>Designed and built a Software lab and network, using Linux as
+ a router/firewall into the lab.</li>
+
+ <li>Designed and implemented a streaming video demo which ran
+ across the company's product, which was presented to future
+ Venture Capitalist firms.</li>
+ </ul>
+
+ <hr noshade>
+
+ <h3>Copper Mountain Networks, Palo Alto, CA. Systems Administrator</h3>
+
+ <p>01-04</p>
+
+ <ul>
+ <li>Senior Systems Administrator for a site that included a user
+ base of Executives, Marketing and Engineers: 150 desktops and 25
+ servers.</li>
+
+ <li>Installed and configured various NT networking components in a
+ multiple NT domain environment: PDC, BDCs, WINS, and </li>
+
+ <li>Exchange 5.5 servers.</li>
+
+ <li>Implemented various networking services using both Linux and
+ NT: DNS, NIS, DHCP and Samba.</li>
+
+ <li>Managed T-1s and administered the routers, which connected the
+ company to the other corporate sites, Fremont and San </li>
+
+ <li>Diego as well as the internet.</li>
+
+ <li>Installed and maintained inter-departmental websites using
+ Apache and Linux</li>
+
+ <li>Configured Linux boxes as routers and firewalls for test
+ purposes in a lab environment.</li>
+
+ <li>Created Audio/Video streaming servers, both on demand and
+ Multi-cast streams, using both Linux and Microsoft's Windows </li>
+
+ <li>Streaming Media Server, to generate 'real world' traffic, for
+ use with in house test networks.</li>
+
+ <li>Designed and built a 1,400 square foot Engineering lab which
+ consisted of centralized patch panels, telco racks, descending
+ </li>
+
+ <li>cable trays, benches, power and storage areas. </li>
+
+ <li>Installed, configured and administered a network of Sun
+ workstations and servers, Linux, NT and Win2K workstations in the
+ Software Engineering Lab.</li>
+
+ <li>Hosted DNS and NIS for machines in the Software Engineering
+ Lab.</li>
+
+ <li>Created a simulated network of SNMP agents (6000), using
+ multi-homed Linux work-stations (16) and JAVA, for internal
+ testing of Network Management Software.</li>
+ </ul>
+
+ <hr noshade>
+
+ <h3>Ipsilon Networks/Nokia, Sunnyvale, CA. Systems Administrator</h3>
+
+ <p>97 - 98</p>
+
+ <ul>
+ <li>Provided help desk support for a user base of 150 users that
+ included a worldwide sales team.</li>
+
+ <li>Supported a variety of operating systems (10+) in a complex IP
+ network.</li>
+
+ <li>Performed daily Systems Administrator tasks: creating new user
+ accounts, setting up machines, Corporate backups and </li>
+
+ <li>updating DNS and NIS records.</li>
+
+ <li>Administered Firewall, CheckPoint and installed client
+ software, Secure Remote.</li>
+ </ul>
+
+ <hr noshade>
+
+ <h3>N.E.T., Redwood City, CA. Systems Administrator</h3>
+
+ <p>96-97</p>
+
+ <ul>
+ <li>Established a network of SGI workstations for the mechanical
+ engineering team.</li>
+
+ <li>Provided SGI training to the internal IT department.</li>
+
+ <li>Provided help desk support, in an Enterprise environment,
+ which consisted of an engineering team (200+ users) with Solaris
+ workstations on the desktop.</li>
+
+ <li>Participated as a team player, in the redesign of the
+ engineering network infrastructure, by planning the new lab layout
+ and consolidation of equipment into a smaller location.</li>
+ </ul>
+
+ <hr noshade>
+
+ <h3>Adaptive, Redwood City, CA, Software Test Engineer</h3>
+
+ <p>93 - 96</p>
+
+ <ul>
+ <li>Developed, automated and implemented test cases, to test
+ complex broadband networking switch software, in a Unix
+ environment</li>
+
+ <li>Managed and improved the software build process, by automating
+ the process with scripts, thus decreasing the build time by
+ 20%.</li>
+
+ <li>Designed, moved, and managed Software Engineering Test Labs
+ and received an award.</li>
+ </ul>
+
+ <hr noshade>
+
+ <h3>Adaptive, Redwood City, CA ManufacturingTest Technician</h3>
+
+ <p>91 - 93</p>
+
+ <ul>
+ <li>Built, tested, debugged and configured Sonet Broadband
+ Switches to support customer shipment schedules</li>
+
+ <li>Documented test procedures.</li>
+
+ <li>Trained manufacturing personnel on all system test
+ procedures.</li>
+
+ <li>Assisted in the layout of both the system test and mechanical
+ assembly areas.</li>
+
+ <li>Completed training required for ISO 9002 certification</li>
+ </ul>
+
+ <hr noshade>
+
+ <h3>Network Equipment Technologies, Redwood City, CA Manufacturing
+ Test Technician</h3>
+
+ <p>89 - 91</p>
+
+ <ul>
+ <li>Effectively tested modules at a system level in a temperature
+ controlled environment meeting all production schedules.</li>
+
+ <li>Assisted Advanced Manufacturing in troubleshooting test
+ scripts.</li>
+ </ul>
+
+ <hr noshade>
+
+ <h3>Electronic Arts, San Mateo, CA, Customer Support</h3>
+
+ <p>88 - 89</p>
+
+ <ul>
+ <li>Assisted in resolving product related problems to meet
+ production schedule.</li>
+
+ <li>Provided technical phone support to customers.</li>
+
+ <li>Participated in beta testing of various software
+ packages.</li>
+ </ul>
+
+ <hr noshade>
+
+ <h3>Education</h3>
+
+ <p>Unix Systems Administration Certificate - U.C. Santa Cruz Extension<br>
+ Sun Networking Certificate - Sun Micro Systems<br>
+ Windows 95 and Windows NT 4.0 Training - Mastering Computers</p>
+
+ <h3>Computer Skills</h3>
+
+ <p>Solaris, Linux, Windows 2000</p>
+
+ <h3>References</h3>
+
+ <p>Available upon request</p>
+
+ <?php copyright ();?>
+
+<script language="JavaScript" src="/JavaScript/Menus.js" type="text/javascript"></script>
+
+</body>
+</html>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+ <title>ClearSCM: Our People: Tom Connor</title>
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Article.css">
+ <link rel="stylesheet" type="text/css" media="print" href="/css/Print.css">
+ <link rel="SHORTCUT ICON" href="http://clearscm.com/favicon.ico" type="image/png">
+ <?php
+ include "../../php/clearscm.php";
+ menu_css ();
+ ?>
+</head>
+
+<body id="homepage">
+
+<?php heading ();?>
+
+<div id="page">
+ <div id="content">
+ <?php start_box ("cs2")?>
+ <h2>Tom Connor</h2>
+ <p style="text-align:center">Software Developer<br>
+ Build/Release Engineer<br>
+ Software Configuration Manager<br>
+ <a href="tomhillconnor@yahoo.com">tomhillconnor@yahoo.com</a>
+ <p style="text-align:center"><a href="Resume.doc">MS Word format</a></p>
+ <?php end_box ();?>
+
+<h2>Synopsis</h2>
+
+<p>Sr. Software Engineer with over 20 years of varied experience as a
+software developer. Specializations in Software Configuration
+Management, Release Engineering, Build Engineering, workflow
+automation, Installer Development, and Deployment
+Engineering. Creative problem solver with strong analytical and
+communication skills.</p>
+
+<h2>Technical Skills</h2>
+
+<h3>Langauges</h3>
+
+<p>Perl, Java, C/C++, Visual Basic, Awk, XML, bash, korn, sh,
+InstallScript, 4NT/4DOS shell, NT/DOS Shell, Ratfor, FORTRAN,
+PostScript, Assembler</p>
+
+<h3>Tools</h3>
+
+<p>ClearCase, UCM, ClearQuest, ClearTrigger, MultiSite, cqperl,
+clearmake, make, gmake, omake, Maven, Cruise Control, Ant, Visual
+SourceSafe, PVCS, InstallShield, InstallAnywhere, InstallBuilder,
+InnoSetup, CodeWright, Eclipse, Interwoven TeamSite</p>
+
+<h3>Environments</h3>
+
+<p>Redhat Linux, Sun Solaris, Cygwin, Windows XP/2k/NT/9x/3x, DOS,
+other unix (Tandem Non-StopUX, AIX, HPUX, Solaris, QNIX), VM/CMS,
+OS/TSO, VAX/VMS</p>
+
+<h2>Business Experience</h2>
+
+<h3>Computer Sciences Corporation (11/2008 - present)</h3>
+
+<h3><i>Tools Writer, PDTools Team, MUOS program, General Dynamics,
+Scottsdale, AZ</i></h3>
+
+<ul>
+ <li>The RAN tools team and other tools teams was reorganized into
+ the PD Tools team, with division-wide scope.</li>
+
+ <li>I continue to support MUOS RAN, ClearCase, and ClearQuest, but
+ am now focused more on writing workflow automation tools for
+ MUOS-wide application, primarily in perl, utilizing the ClearQuest
+ API. The focus is much more on the Windows platform, though of
+ course I make the tools cross-platform where feasible.</li>
+</ul>
+
+<h3>Computer Sciences Corporation (6/2007 - 11/2008)</h3>
+
+<h3><i>Software Configuration Engineer, SDE Tools Team, MUOS program,
+General Dynamics, Scottsdale, AZ</i></h3>
+
+<ul>
+ <li>At close of Land Warrior program, I transitioned to a much
+ larger SCM challenge, joining the 15-person RAN Software Development
+ Environment Tools Team. The team uses ClearCase, ClearQuest,
+ CearTrigger, Build Forge, etc. to achieve SCM of a large
+ codebase. This is over 300 VOBs, 3 million lines of code, in a
+ complex hybridized UCM/Base-ClearCase environment, with lots of
+ triggers and heavy workflow automation.</li>
+
+ <li>Writing GUI and command-line tools in Perl, Tk, and C++.</li>
+
+ <li>Supporting SWIT teams with SCM, UCM project architecture,
+ workflow automation, and test automation</li>
+
+ <li>Providing UCM project architecture, UCM administration, writing
+ UCM support tools</li>
+
+ <li>Developing/documenting new and changed procedures</li>
+
+ <li>Diagnosing and solving user problems.</li>
+
+ <li>Diagnosing, proposing, implementing improvements to the CM tools
+ and workflow automation</li>
+
+ <li>Lead for implementing automated testing of overall SCM workflow
+ automation.</li>
+
+ <li>Doing ClearCase and ClearQuest administration</li>
+</ul>
+
+
+<h3>Computer Sciences Corporation (3/05 - 6/07)</h3>
+
+<h3><i>Build Engineer/Software Configuration Manager, Land Warrior
+program, General Dynamics, Scottsdale, AZ</i></h3>
+
+<ul>
+ <li>I was asked to rejoin this development team, to lead the
+ 2-person SCM/Build/Release sub-team. This is a pure linux and
+ linux-embedded development effort using Open Source components,
+ in-house linux kernel and driver modification, and object-oriented
+ application development using C++.</li>
+
+ <li>Responsible for SCM in a linux environment. Major tools:
+ Clearcase/UCM (Unified Change Management) and Bugzilla.</li>
+
+ <li>Made major improvements in build and release automation. I
+ developed a toolset of 80+ scripts totaling over 5,800 lines of bash
+ and perl code.</li>
+
+ <li>Responsible for document/data CM in a Windows environment.
+ Major tools: SubVersion.</li>
+
+ <li>Wrote SCM plans that embodied best practices compliant with CMMI
+ Level 3.</li>
+
+ <li>Supervised the design of Data Configuration Management
+ Plans.</li>
+
+ <li>Developed SCM audit procedures.</li>
+
+ <li>For enhanced change control, I improved the ClearCase/UCM
+ coupling to Bugzilla, our bug-tracking tool.</li>
+
+ <li>Performed Linux and WinXP administration.</li>
+
+ <li>Provided ClearCase/UCM mentoring and training to
+ developers.</li>
+
+ <li>Performed ClearCase administration and troubleshooting.</li>
+
+ <li>Designed/created ClearCase/UCM projects and project strategies, to
+ support both the development team and the automated testing
+ team.</li>
+
+ <li>Developed makefiles.</li>
+
+ <li>Developed RPM-based installation packages.</li>
+
+ <li>Diagnosed and fixed build scripts and makefiles written by
+ others.</li>
+
+ <li>Made contributions to the application code.</li>
+
+ <li>Developed disaster recovery plans and carried out
+ procedures.</li>
+
+ <li>Performed builds, prepared media, provided deliverables to the
+ customer.</li>
+
+</ul>
+
+<h3>JP Morgan Chase Investment Bank (11/04 - 3/05)</h3>
+
+<h3><i>Build Engineer/Software Configuration Manager</i></h3>
+
+<ul>
+ <li>Worked as an employee in the Houston Development Center.</li>
+
+ <li>Worked with Ant, Maven, and Cruise Control in a
+ Java/BEA/Websphere shop.</li>
+
+ <li>Worked on a ClearCase UCM implementation team, developing
+ policies and standards for UCM implementation and working with
+ individual teams, taking them through the process of conversion
+ (typically from CVS) to Clearcase and UCM.</li>
+
+ <li>Left to heed the call to return to the team I left at CSC. JPMC
+ says please consider them in futery -- I’d be welcome back.</li>
+</ul>
+
+<h3>Computer Sciences Corporation (5/04 - 10/04)</h3>
+
+<h3><i>Build Engineer, Land Warrior program, General Dynamics, Scottsdale, AZ</i></h3>
+
+<ul>
+ <li>Became part of a two-man Software Configuration Management and
+ Build team administering Linux and Clearcase in a 20-developer shop.
+ </li>
+
+ <li>In a pure Linux shop, doing Clearcase UCM management, Clearcase
+ administration, builds, build automation.</li>
+
+ <li>Laid off, along with most of the team, because of a work
+ stoppage.</li>
+</ul>
+
+<h3>Dell (3/04 - 4/04)</h3>
+
+<h3><i>Build/Installer Engineer</i></h3>
+
+<ul>
+ <li>Joined a 10-person PowerEdge/OpenManage installer team.</li>
+
+ <li>Although originally hired to fix java bugs in an older suite
+ installer, I worked with InstallShield DevStudio 9, setting up build
+ scripts for complex msi/msm builds and doing similar things for
+ producing Linux RPM builds.</li>
+</ul>
+
+<h3>Dell (6/03 - 3/04)</h3>
+
+<h3><i>Build/SCM Engineer</i></h3>
+
+<p>Joined the 6-person PowerEdge/OpenManage SCM Team, to assist with a
+massive migration into ClearCase Multi-Site/UCM, and to
+design/implement a CMM Level 2 compliant Build Management Facility.
+However, the BMF was shelved and I took on the task of developing
+extended monitoring and reporting capability around the ClearCase and
+UCM activities.</p>
+
+<p>Current responsibilities are:</p>
+
+<ul>
+ <li>Writing report-generators for management’s view into the
+ activities of teams based in ClearCase MultiSite/UCM.</li>
+
+ <li>These custom reports track development efforts by reporting and
+ doing metrics on UCM projects, activities, baselines, streams, and
+ components, and provide notification capability for conditions that
+ may need attention.</li>
+
+ <li>These reports run daily and are presented on the SCM internal
+ website. In addition, users can generate their own reports as
+ needed. The report generators, 7k lines of Perl, are in the form of
+ several scripts that share a re-usable library of common code.</li>
+
+ <li>Devised an automated regression-test framework, following Kent
+ Beck’s Extreme Programming approach of first writing the test,
+ making sure it fails, then writing the functionality that will make
+ the test succeed. The result is that most of the functionality can
+ be regression-tested with a single command, and this has been a big
+ help in rapidly evolving these highly visible reports without a lot
+ of error.</li>
+
+ <li>As a part of the reporting/monitoring effort, driving a project
+ to create a shadow database in SQL Server, for the purpose of
+ providing a more general query/drill-down/reporting capability.
+ This involves directing the work of a DB developer, and getting
+ requirements from three managers. In addition, suggested using
+ Rational ClearQuest as a database engine, to provide this database
+ engine capability, have received approval, and we are about to
+ engage in an evaluation.</li>
+
+ <li>Have learned how to write and interface custom reports to
+ ClearCase Report Builder.</li>
+
+ <li>Run a bi-weekly meeting with the monitoring/reporting
+ stakeholders, 6 representatives from various management,
+ development, and test areas, for the purpose of iteratively
+ gathering requirements, in order to ensure the project satisfies
+ it's customer's needs.</li>
+
+ <li>Consult with teams on build issues and build automation
+ design.</li>
+
+ <li>In charge of driving the SCM Team’s process improvement
+ effort, which involves facilitating a weekly SCM team meeting and
+ associated process improvement supervisory activities.</li>
+
+ <li>Identifying needs and writing ClearCase triggers for workflow
+ enhancement.</li>
+
+ <li>Setting up ClearCase and NT Server monitoring processes.</li>
+
+ <li>Provided scripts to help teammates with migration efforts, for
+ example to correct case errors in element names when doing secondary
+ imports from SourceSafe to ClearCase.</li>
+</ul>
+
+<h3>Marsh PM Internet Technology Group (9/02 - 11/02)</h3>
+
+<h3><i>Consultant</i></h3>
+
+<ul>
+ <li>Was hired to create the next generation company-wide automated
+ software production system. This consisted of two efforts:</li>
+
+ <li>Determine requirements and specify the release engineering
+ process.</li>
+
+ <li>develop an automated build system:</li>
+
+ <li>Deterministic: build system completely determines build
+ environment so that build proceeds from a known state.</li>
+
+ <li>Repeatable: build state info is archived so that past build
+ environments can be re-constructed.</li>
+
+ <li>Accountable: all build states, activities, and outputs are
+ recorded in a structured way.</li>
+
+ <li>Extensible: the build system framework is independent of that
+ which is built. A well documented interface permits new build
+ inputs and outputs to be spedified.</li>
+</ul>
+
+<h3>Interwoven (9/01 - 8/02)</h3>
+
+<h3><i>Senior Release Engineer</i></h3>
+
+<ul>
+ <li>Designed/implemented an automated dependency-tracking system</li>
+
+ <li>Interwoven needed an accurate and automated way to determine
+ exactly what files to include in a service pack or patch. </li>
+
+ <li>Made major contributions to the design, and did the
+ implementation of a system that compares the current build to the
+ baseline build, and provides this list of only files that have
+ changed in a meaningful way. This meant writing sophisticated
+ language-aware tools for one-time initialization of over 100,000
+ source files, plus new workflow and build-time production
+ modules.</li>
+
+ <li>Wrote these in Perl, such that they could run on both UNIX and
+ Win2k platforms. The work required that I gain an in-depth
+ understanding of the internals of both UNIX and Windows versions of
+ TeamSite 4.2-5.51, the source file organization, the source code
+ branches and branching strategy, source generators and the complex
+ Interwoven build system. </li>
+
+ <li>Since tracking the dependencies required embedding tracking
+ information in source and built files, I had to understand compiler
+ output formats (C, C++, and Java), as well as understand the syntax
+ of XML, HTML, ASP, and JSP files, in order to create a scanner that
+ could locate and read the tracking data in built output
+ (i.e. executables, Java JAR/WAR/EAR files, etc.) </li>
+
+ <li>As part of this effort I also developed a sophisticated perl
+ TeamSite Workflow module for the source file submission
+ workflow.</li>
+
+ <li>maintained complex Windows and UNIX service pack
+ installers.</li>
+
+ <li>These were being put together by hand, by copying the previous
+ service pack’s source. There was no source control. The UNIX
+ service pack install scripts were Bourne shell based. The Windows
+ service pack installers were based in InstallShield 5.5 or 6.3, with
+ custom InstallScript. When I started, there were many versions of
+ these installers, each with slightly different functionality, and a
+ new one was created for each new service pack release. Devised
+ methods and scripts to more effectively reuse existing code. This
+ involved comparing all the installer variations and re-writing large
+ parts of the installer code, to support modularized functionality.
+ Once the installers were properly modularized, I aggregated all the
+ variations into a single configurable installer, which I made
+ configurable from property files. I did this for both UNIX and
+ Windows installers.</li>
+
+ <li>During this process I discovered that locked file support was
+ not being used in the Windows installers, and I implemented this
+ feature, which involved enhancing the way NT services were
+ stopped/started versus when to reboot, and how to ensure that
+ post-install configuration steps do indeed get postponed until after
+ the reboot, if there was one.</li>
+</ul>
+
+<h3>Trilogy Development Group (5/98 - 7/01)</h3>
+
+<h3><i>Build Manager and Installation Engineer</i></h3>
+
+<ul>
+ <li>Led Trilogy’s software build and installation teams and
+ trained/mentored 5 other team members. This team produced builds
+ and installers, but also functioned as a company-wide advocate for
+ Software Configuration Management/Release Engineering best
+ practices.</li>
+
+ <li>Successfully improved Trilogy’s software build process.
+ Technology platforms included C++/VB/COM+/Windows, EJB/J2EE, and
+ other cross-platform Java. This was a complex build system that
+ produced builds for weekly releases of over 50 products in several
+ suites. When I started, there were 5 build machines and one server.
+ I automated many of the manual steps, permitting the system to grow
+ to 20 build machines and 6 servers, with web-driven hourly
+ builds.</li>
+
+ <li>Helped develop a cutting edge in-house source control system,
+ using ClearCase as an engine. I developed procedures for converting
+ source trees from the old systems to the new system. Contributed to
+ the modification of the build system to accommodate the new source
+ control system.</li>
+
+ <li>Working with a PhD in SCM and a ClearCase expert as teammates, I
+ learned how to administer a complex Rational ClearCase source
+ control system consisting of hundreds of VOBs and thousands of
+ Views. I contributed to strategy for VOB automated backups, and
+ View and VOB organization. I gained experience with command line
+ usage of ClearCase, and how to call it from Perl scripts. While
+ solving a subtle and recurring intermittent NT server crash, I
+ became aware of some of ClearCase's limitations, and it's
+ implications for our administration strategy. I participated in
+ discussions on trigger strategy, and helped analyze how to implement
+ ClearCase Multi-Site between Austin and India.</li>
+
+ <li>Administered large (400,000 files!) PVCS Version Manager
+ system</li>
+
+ <li>Administered large (900,000 files!) Visual SourceSafe system.
+ As the main company resource, I worked with groups in Core
+ Development, Consulting, and several of Trilogy’s spinoffs.</li>
+
+ <li>mentored disparate groups on best usage practices for using the
+ main database, and for administering their own database, if
+ justified. This included describing VSS design flaws, admonitions
+ about the impact that renaming has on repeatability of builds, the
+ difference between deleting and purging, the sanctity of the
+ archive, how to avoid corrupting the archive, backup strategies,
+ when to branch, etc.</li>
+
+ <li>Interfaced the automated build system to VSS databases from the
+ command line.</li>
+
+ <li>Wrote conversion scripts when we moved on to another source
+ control system.</li>
+
+ <li>Set up customer-specific secure VSS databases, accessed by our
+ on-site consultants.</li>
+
+ <li>Upgraded main database to a RAID 5 server, and improved the
+ backup strategy. </li>
+
+ <li>Devised best practices for other VSS administrators to
+ follow.</li>
+
+ <li>Analyzed and fixed multiple VSS databases.</li>
+
+ <li>Analyzed impact of moving from VSS 4 to VSS 5 to VSS 6.</li>
+
+ <li>Determined the main company VSS database was too large and
+ devised the strategy for dividing it into smaller pieces.</li>
+
+ <li>Administered and improved multiple build system NT servers and
+ source control NT servers, as well as the 10-20 build machines.</li>
+
+ <li>Developed tools to further automate the build and release
+ process</li>
+
+ <li>enhanced complex InstallShield-based Installers. These
+ installers were re-usable, configurable from sets of INI files, and
+ consisted of 30,000+ lines of InstallScript.</li>
+
+ <li>Developed Java-based cross-platform installers using
+ InstallShield MultPlatform, including writing custom java
+ extensions.</li>
+
+ <li>Helped develop Java-based cross-platform installer to replace
+ InstalShield MultiPlatform</li>
+
+ <li>Developed automated source escrow generation system</li>
+
+ <li>Helped develop an automated test system. Trilogy wanted to
+ create a web-driven automated test lab to support an Extreme
+ Programming inspired automated test framework. I provided input on
+ how best to layer software onto a test machine, starting with a
+ ghost image of the desired basic OS, followed by optional
+ re-packaged installations of Oracle, Office, etc.</li>
+
+ <li>Served as a resource for the developers and QA engineers on
+ source code <li><P CLASS="western" ALIGN=JUSTIFY><FONT FACE="Arial,
+ sans-serif"><FONT SIZE=2>Integrated third party tools and components
+ into the build and release process.</font>
+
+ <li>Interfaced with Product Management, Consulting, Development, and
+ QA to develop and implement product installation, packaging,
+ licensing, and distribution strategy.</li>
+
+ <li>Performed scheduled and on-demand software product builds for
+ Development and QA</li>
+
+ <li>Developed and implemented product-wide configuration management
+ processes and practices to support new and existing products.</li>
+
+ <li>Developed revision control and software process policies and
+ interacted with groups across Development and Consulting on build
+ and release issues.</li>
+</ul>
+
+
+<h3>Data Strategies International (11/97 - 4/98)</h3>
+
+<h3><i>Consultant</i></h3>
+
+<ul>
+ <li>Wrote Windows device driver for Network Packet Driver (16 bit
+ DLL, written in C)</li>
+
+ <li>Advanced Micro Devices</li>
+
+ <li>Worked on improvements to AMD’s software test and simulation
+ facility</li>
+</ul>
+
+<h3>VTEL Corporation (11/94 - 11/97)</h3>
+
+<h3><i>Staff Engineer, Windows Programmer (18 months as consultant,
+then 18 months as employee)</i></h3>
+
+<ul>
+ <li>Devised an ownership protocol whereby Diagnostics and
+ Conferencing software could safely share the hardware. Implemented
+ in C++ as a DLL with a C API, this centralized all hardware access
+ services.</li>
+
+ <li>Ported DOS-based diagnostics to Win32 platform, and
+ designed/implemented GUI.</li>
+
+ <li>Responsible for all Plug and Play aspects of VTEL hardware.</li>
+
+ <li>Developed sophisticated software installers using InstallShield
+ InstallScript.</li>
+
+ <li>Created the Build Team and trained the personnel.</li>
+
+ <li>Provided Windows development support</li>
+
+ <li>Analyzed and fixed problems with low-level DLLs</li>
+</ul>
+
+<h3>Computer Task Group (10/91 - 11/94)</h3>
+
+<h3><i>Consultant</i></h3>
+
+<ul>
+ <li>Database development in C on a QNIX-based distributed
+ environment.</li>
+
+ <li>Dell Computers</li>
+
+ <li>GUI development using VB</li>
+
+ <li>Tandem Computers</li>
+
+ <li>Test automation development for testing UNIX real-time kernel
+ processes.</li>
+</ul>
+
+<h3>Shafir, Inc. (10/91 - 11/94)</h3>
+
+<h3><i>Cofounder, Shafir, Inc.</i></h3>
+
+<ul>
+ <li>founded this startup in the computer mapping and eCommerce
+ space. Two co-founders and three employees.</li>
+
+ <li>Developed GPS-enabled street-mapping graphics software using VB
+ and VC++</li>
+
+ <li>Did Java toolkit development. We won a JARS Top 5% Award.</li>
+
+ <li>Did Java-based business graphics toolkit</li>
+
+ <li>Wrote a Java-based installer</li>
+</ul>
+
+<h3>Frank Russell Corporation</h3>
+
+<ul>
+ <li>Provided graphics driver support for Impressionist-based shop
+ producing thousands of graphs and charts per month.</li>
+</ul>
+
+<h3>Execucom</h3>
+
+<ul>
+ <li>Eight years as software developer on Graphics Team (5 years as
+ Lead for the Impressionist team)</li>
+</ul>
+
+<h2>EDUCATION</h2>
+
+<ul>
+ <li>BS in Physics, University of Texas, Austin</li>
+
+ <li>Graduate work (60 hrs) in Theoretical High Energy Nuclear
+ Physics, Texas A&M University</li>
+</ul>
+</div>
+</div>
+</body>
+</html>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+ <title>ClearSCM: Addendum</title>
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Article.css">
+ <link rel="stylesheet" type="text/css" media="print" href="/css/Print.css">
+ <link rel="SHORTCUT ICON" href="http://clearscm.com/favicon.ico" type="image/png">
+
+ <?php
+ include "php/clearscm.php";
+ menu_css ();
+ ?>
+</head>
+
+<body id="homepage">
+
+<?php heading ();?>
+
+<div id="page">
+ <div id="content">
+ <h2>Contract Addendum</h2>
+
+ <h2><a href="Contract Addendum.doc">MS Word Copy</a></h2>
+
+ <p>This addendum is between ClearSCM, Inc. or a representative
+ from ClearSCM, Inc., hereafter known as <b>Contractor </b> and <u> </u>,
+ hereafter known as <b>Agent </b>or <b>Agency</b>, with
+ respect to the project at <u> </u>, hereafter known as
+ <b>Client</b>, and is made on <u> </u>. This addendum supersedes
+ or augments any prior agreements made between <b>Contractor</b>
+ and <b>Agency</b> regarding any engagements with the
+ <b>Client</b>, including but not limited to the afore-mentioned
+ project.</p>
+
+ <p><b>Terms:</b> ClearSCM's terms are Net/30 with a 2% late charge
+ that will be applied to the invoice amount for any invoices not
+ paid in the initial 30 day period. Exceptions can be made for the
+ first pay period and if so are stipulated here:</p>
+
+ <p><u> </u></p>
+
+ <p><b>Contract Duration:</b> The contract duration shall be at
+ least <u> </u> from the agreed upon start date. If the contract is
+ terminated for any reason except non-performance, then an early
+ termination fee will be assessed:</p>
+
+ <ul>
+ <li>For contracts of 6 months or less - 30 day early termination
+ fee</li>
+
+ <li>For contracts longer than 6 months - 60 day early
+ termination fee</li>
+ </ul>
+
+ <p>This early termination fee will be equal to 30 (or 60) days of
+ assumed 8 hour billable duration and will be assessed against the
+ <b>Agent</b>. Standard rate and terms apply.</p>
+
+ <p>Non-performance shall be solely judged by the <b>Client</b>, and
+ concerns over non-performance shall be provided in written form to
+ the <b>Contractor</b> by the <b>Client</b>. The <b>Contractor</b> shall
+ always have a reasonable period of time from the date of the
+ written notice to improve performance to the <b>Client</b>'s satisfaction
+ before the contract may be terminated without incurring the early
+ termination fee.</p>
+
+ <p><b>Rate Disclosure:</b> The hourly rate that the <b>Client</b> is
+ paying the <b>Agent</b> is: <u> </u>. The rate that the
+ <b>Contractor</b> is billing the <b>Agent</b> is: <u> </u>.</p>
+
+ <p><b>After Hours Work:</b> The <b>Contractor</b> is willing to
+ work hours above and beyond the standard 8 hours a day and/or 40
+ hours a week and is willing to carry a pager or be “on
+ call” to the <b>Client</b>. No hours will be billed for being
+ “on call.” However any hours actually worked as a
+ result of being called into action in (beyond the standard 8 hours
+ a day/40 hours a week) will be billed at the standard rate. The
+ <b>Contractor</b> does not negotiate or juggle compensatory time
+ off for hours worked after hours.</p>
+
+ <p><b>Vacation/Holidays and Furloughs:</b> The <b>Contractor</b>
+ normally works 8 hours a day for 5 days in a standard work week of
+ 7 days. Standard holidays are observed:</p>
+
+ <ul>
+ <li>New Year's Day (January 1)</li>
+
+ <li>Birthday of Martin Luther King, Jr. (Third Monday in
+ January).</li>
+
+ <li>Washington's Birthday (Third Monday in February).</li>
+
+ <li>Memorial Day (Last Monday in May).</li>
+
+ <li>Independence Day (July 4).</li>
+
+ <li>Labor Day (First Monday in September)</li>
+
+ <li>Columbus Day (Second Monday in October).</li>
+
+ <li>Veterans Day (November 11).</li>
+
+ <li>Thanksgiving Day (Fourth Thursday in November).</li>
+
+ <li>Christmas Day (December 25).</li>
+ </ul>
+
+ <P>Holidays are considered non-billable days unless the <b>Client</b>
+ requests, and the <b>Contractor</b> agrees, that the
+ <b>Contractor</b> should work that holiday. Holiday billable rate
+ will be 2 times the normal billing rate.</p>
+
+ <p>The <b>Contractor</b> agrees to make reasonable accommodations
+ to work within the <b>Client</b>'s vacation schedule and will give at
+ least 2 weeks notice before any vacation time it taken. If the
+ <b>Client</b> shuts down or furloughs their company (thereby preventing
+ <b>Contractor</b> from working under the contract) then there will
+ be a $2000 furlough fee assessed against the <b>Agent</b> for each
+ week the <b>Contractor</b> is unable to work under the Contract.
+ This fee shall be pro-rated per business day (rounded up), in the
+ event only a partial week is lost to furlough..</p>
+
+ <p><b>Pre-existing art / Copyright:</b> ClearSCM utilizes a
+ library of development / diagnostic tools. Such tools contain code
+ both written by <b>Contractor</b> and by others (e.g. GPL'd
+ code). To the extent of <b>Contractor</b>'s copyright interest in
+ the tools, <b>Client</b> is hereby granted a royalty-free license to use
+ these tools in-house for the duration of the contract, including
+ modifications made by <b>Contractor</b> during the contract. Upon
+ full payment by <b>Agency</b> under the contract, <b>Client</b>'s
+ royalty-free in-house license becomes a perpetual one. This license
+ notwithstanding, unless otherwise agreed to in writing, ClearSCM
+ retains the rights to all code developed prior to the start of
+ this contract or during this contract.</p>
+
+ <p><b>Contractor</b> offers NO WARRANTY regarding the tools
+ (regarding performance, functionality, non-infringement of
+ copyright or patent, or on any other matter), and EXPRESSLY
+ DISCLAIMS any warranty that might be implied by law. Such
+ DISCLAIMED WARRANTIES include, but are not limited to, the IMPLIED
+ WARRANTY OF MERCHANTABILITY, THE IMPLIED WARRANTY OF FITNESS FOR A
+ PARTICULAR PURPOSE, AND ANY IMPLIED WARRANTIES OF
+ NON-INFRINGEMENT.</p>
+
+ <p></p>
+
+ <p>BY: <u> </u> DATE: <u> </u><br>
+ ClearSCM, Inc.</p>
+
+ <p></p>
+
+ <p>BY: <u> </u> DATE: <u> </u><br>
+ Agent</p>
+
+ </div>
+
+ <?php copyright ("2001");?>
+
+<script language="JavaScript" src="/JavaScript/Menus.js" type="text/javascript"></script>
+
+</body>
+</html>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
+<html>
+<head>
+ <title>Business Card</title>
+</head>
+<body>
+
+<style type="text/css">
+.card a:link {
+ color: white;
+}
+
+.card a:visited {
+ color: white;
+}
+
+.card a:hover {
+ color: white;
+ background-color: #004080;
+ text-decoration: underline;
+}
+
+.card a:active {
+ color: #333;
+}
+
+.name a:link {
+ color: #fc0;
+}
+
+.name a:visited {
+ color: #fc0;
+}
+
+.name a:hover {
+ color: #fc0;
+ background-color: #333;
+ text-decoration: underline;
+}
+
+.name a:active {
+ color: red;
+}
+
+td {
+ font: Helvetica Arial Serif
+ font-size: 16px;
+}
+</style>
+
+<table bgcolor="#666666" border="0" cellpadding="0" cellspacing="0" width="376" align="center">
+ <tbody>
+ <tr>
+ <td><a class=card href="http://clearscm.com"><img border=0 src="/Logos/ClearSCM.jpg" height="84" width="376"></a></td>
+ </tr>
+ <tr>
+ <td style="margin: 10px;">
+ <table border="0" cellpadding="5" cellspacing="0" width="100%">
+ <tbody>
+ <tr>
+ <td valign="top"><div class=name><a href="http://defaria.com"><b>Andrew DeFaria</b></a></div>
+ <table border="0" cellpadding="0" cellspacing="0" width="100%">
+ <tbody>
+ <tr>
+ <td valign="top"><font color=white><b>President</b></font></td>
+ <td align="right"><div class=card><a href="http://clearscm.com"><b>ClearSCM, Inc.</b></a></div></td>
+ </tr>
+ <tr>
+ <td> </td>
+ <td align="right"><font color=white size=-1>1742 Seagull Court #101</font></td>
+ </tr>
+ <tr>
+ <td><font color=white size=-1><i>The power to see clearly...</i></font></td>
+ <td align="right"><font color=white size=-1>Reston, Virginia 20194-4309</font></td>
+ </tr>
+ <tr>
+ <td><font color=white size=-1><i>Professional SCM Consultants</i></font></td>
+ <td align="right"><font color=white size=-1>Phone: (408) 596-4937</font></td>
+ </tr>
+ <tr>
+ <td><font color=white><div class=card><a href="http://ClearSCM.com">http://ClearSCM.com</a></div>
+ <td align="right"><font color=white><div class=card><a href="mailto:Info@ClearSCM.com">Info@ClearSCM.com</a></div></font></td>
+ </tr>
+ </tbody>
+ </table>
+ </td>
+ </tr>
+ </tbody>
+ </table>
+ <font color="#ffcc00"></font></td>
+ </tr>
+ </tbody>
+
+</table>
+ </body>
+</html>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+
+ <title>ClearSCM: Clearcase: Triggers: Evil Twin</title>
+
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Article.css">
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Code.css">
+ <link rel="stylesheet" type="text/css" media="print" href="/css/Print.css">
+ <link rel="SHORTCUT ICON" href="http://clearscm.com/favicon.ico" type="image/png">
+
+ <!-- Google Analytics
+ <script src="http://www.google-analytics.com/urchin.js" type="text/javascript">
+ </script>
+ <script type="text/javascript">
+ _uacct = "UA-89317-1";
+ urchinTracker ();
+ </script>
+ Google Analytics -->
+
+ <?php
+ include "../php/clearscm.php";
+ menu_css ();
+ ?>
+</head>
+
+<body>
+
+<?php heading ();?>
+
+<div id="page">
+ <div id="content">
+ <?php start_box ("cs5");?>
+ <h2>Evil Twin Trigger</h2>
+
+ <p>This trigger prevents the creation of <i>Evil Twins</i>. An
+ evil twin is where a user attempt to create a new Clearcase
+ element with the same name as an element that was previously
+ created, perhaps on another branch of the parent
+ directory.</li></p>
+ <?php end_box ();?>
+
+ <h3>What are Evil Twins?</h3>
+
+ <p>Simply put, an evil twin is a condition that can be caused in
+ Clearcase when a user attempts to add an element to source control
+ that has a name that is the same as an element on another
+ branch. If it is allowed to be created it will be difficult if not
+ impossible to merge in the future. You don't want evil twins to be
+ created to start with.</p>
+
+ <p>Let's look a little bit deeper into how this can happen. Let's
+ assume that a user adds the element named "foo" to the directory
+ bin. Sometime later that element name is removed with
+ rmname. Finally assume that it is decided that foo is again
+ needed. When it is recreated the second time you will be creating
+ an evil twin because Clearcase will get confused between foo in
+ say version 3 of the parent directory and this new foo destined
+ for say version 7 of the parent directory.</p>
+
+ <p>Here's a few steps to create the evil twin scenario:</p>
+
+ <div class="code"><pre>
+$ # First check out the current directory and create foo
+$ ct co -nc .
+$ echo "bar" > foo
+$ ct mkelem -nc foo
+$ # Now check it all in
+$ ct ci -nc foo .
+$ # Now check out the parent directory and rmname foo
+$ ct co -nc .
+$ ct rmname foo
+$ ct ci -nc .
+ </pre></div>
+
+ <p>At this point we have a directory with foo in it and then the
+ next version of the directory has foo rmnamed
+ (i.e. uncataloged). Now let's attempt to create an evil twin:</p>
+
+ <div class="code"><pre>
+$ # Let's create foo's evil twin
+$ ct co -nc .
+$ echo "Evil Twin" > foo
+$ ct mkelem -nc foo
+ </pre></div>
+
+ <p>At this point we should see the following dialog box preventing
+ the creation of the evil twin:</p>
+
+ <p><i>Insert dialog box here</i></p>
+
+ <p>This is telling us that we are about to create an evil
+ twin. Note that it also tells us where it found the first twin in
+ the view extended syntax (the part starting with @@). There is
+ another dummy in the bin directory in "andys_branch" version
+ 1.</p>
+
+ <h3>Merging the Original Elements Back</h3>
+
+ <p>The preferred way to resolve this problem is to merge the
+ original elements back from the proper directory version of the
+ parent directory into the current branch. To do this you must
+ first locate the branch where the evil twin existed. From the
+ above example that would be
+ \main\Andrew_Integration\adefaria_Andrew\3. Locate that version of
+ the parent directory (e.g. the adm\bin directory of andy vob in
+ the above example) in the Clearcase Version Tree Browser. To be
+ clear, locate the parent directory for the element dummy in the
+ Clearcase Explorer, right click on it and select Version Tree then
+ look in the version tree for the
+ \main\Andrew_Integration\adefaria_Andrew\3 version.</p>
+
+ <p><b>Note:</b> A good way to find this directory version in
+ directory elements that have large or complicated verion trees is
+ to use the Locate toolbar button (the button with the "flashlight"
+ icon). You can search for versions by version name, branch,
+ etc).</p>
+
+ <p>Next right click on that version (the version of the parent
+ directory that has the original elements) and select Merge
+ to. Your mouse cursor will change to a little "target" icon. Next
+ select the version of the directory that your view selects (this
+ can be found by locating the little "eye" icon).</p>
+
+ <p>Just before you select OK to start the merge make sure you
+ toggle on the Merge the element graphically toggle. This will
+ start cleardiffmrg and prompt you to select each merge.</p>
+
+ <p>This will bring up cleardiffmrg and allow you to confirm each
+ merge of the diredtory. During the merge choose the entries from
+ the parent directory for the elements that you wish to "recover"
+ or "reinstate" .</p>
+
+ <p>Another way to resolve this condition is to hardlink to the
+ previous version of this element but this is not always what you
+ want to do. For one it can be confusing. In any event if you need
+ help because you've hit and evil twin be sure to contact the Help
+ Desk and we'll help you out.</p>
+
+ <?php display_code ("cc/triggers/EvilTwin.pl");?>
+
+ <?php copyright ();?>
+ </div>
+</div>
+
+<script language="JavaScript" src="/JavaScript/Menus.js" type="text/javascript"></script>
+
+</body>
+</html>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+ <title>ClearSCM: Open Source Builds</title>
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Article.css">
+ <link rel="stylesheet" type="text/css" media="print" href="/css/Print.css">
+ <link rel="SHORTCUT ICON" href="http://clearscm.com/favicon.ico" type="image/png">
+
+ <!-- Google Analytics
+ <script src="http://www.google-analytics.com/urchin.js" type="text/javascript">
+ </script>
+ <script type="text/javascript">
+ _uacct = "UA-89317-1";
+ urchinTracker ();
+ </script>
+ Google Analytics -->
+
+ <?php
+ include "../php/clearscm.php";
+ menu_css ();
+ ?>
+</head>
+
+<body id="homepage">
+<?php heading ();?>
+
+<div id="page">
+ <div id="content">
+ <?php start_box ("cs2");?>
+ <h2>Open Source Builds</h2>
+ <?php end_box ();?>
+
+ <p>More and more organizations are using Open Source in their
+ product builds but is the Open Source build mechanisms efficient?
+ This article approaches this subject and shows how often Open
+ Source can be more trouble than it's worth.</p>
+
+ <h3>Open Source Model</h3>
+
+ <p>Much hype has been given to the Open Source movement and
+ rightfully so. Developers can leverage off of Open Source
+ development and modules. This article will not address Open Source
+ in general nor will it go into the legalities of using Open Source
+ in your product. It will instead focus on common Open Source
+ building mechanisms in light how efficient or inefficient they may
+ be when included in your own build mechanisms.</p>
+
+ <h3>Problems with code sharing</h3>
+
+ <p>Unless you employ people who are active in the Open Source
+ community, people who not only participate in using Open Source
+ but also contributing to Open Source, you will enevitably come
+ face to face with a real problem. If you try to improve the Open
+ Source code in any way, unless you donate your changes back to the
+ community at large <b>and</b> those changes are accepted, you will
+ run into the fact that when the next version of the Open Source in
+ question comes out you will have porting work to do. You will need
+ to incorporate your changes with changes from the whole
+ community. In some cases these changes may be done by the
+ community in a similar manner as you had done them. In such cases
+ you can abandon your changes and take the communities solution and
+ then there is one less conflict for you to worry about.</p>
+
+ <p>Other times the communities change is similar to your change
+ but differs enough that you still have to make some minor
+ adjustments. Sometimes you can come up with a more generic way to
+ doing something that will make everybody happy. In such cases you
+ should really consider donating your changes back under the "what
+ comes around goes around" principal. Then next update your generic
+ solution will not need to be merged again.</p>
+
+ <p>Still other times what you need to do is not like what anybody
+ else needs to do or wants. Or it maybe that while your solution is
+ brilliant for the limited set of architectures that you are
+ considered about the community needs to be concerned about a large
+ or different set of architectures and thus cannot accept your
+ solution as a general solution that is good for all. In such cases
+ you are stuck with maintaining your solution for each iterration
+ of the module in question.</p>
+
+ <p>Most developers can relate to the above few paragraphs from an
+ "inside the code" level. But what is often overlooked is that part
+ above the "inside the code" level - at the build and release
+ level.</p>
+
+ <h3>Building Software Efficiently (AKA Build Avoidance)</h3>
+
+ <table border=0 width=50% align=right>
+ <tr>
+ <td>
+ <?php start_box ("cs4");?>
+ <p><i>In the beginning there was make(1) and it was
+ good...</i></p>
+ <?php end_box ();?>
+ </td>
+ </tr>
+ </table>
+
+ <p>Earlier on most software was built using the standard Unix
+ make(1) utility. Make seeks to build only that which need to be
+ build. Make uses a number of assumptions in order to perform its
+ magic. For example, make assumes that you are using 3rd generation
+ languages such as C, FORTRAN, etc. Further make assume you have
+ all of the source contained in files in the file system and that
+ the source code transforms into object code of some kind using
+ some process (e.g. foo.o is derived from foo.c using the C
+ complier).</p>
+
+ <p>As more and more languages evolved luckily make was able to
+ adapt and you could add new transformation rules and tell make how
+ to transform these newer language source files into their
+ respective derived object files and how to piece everything
+ together. Further you could enhance and automatically define
+ dependencies in order to have your build system remain efficient
+ and continue to try to achieve that all elusive "rebuild only that
+ which requires rebuilding".</p>
+
+ <p>However make is easily thwarted if an eye on how make works and
+ how to use it efficiently and effectively is not paid mine. For
+ example, since make uses files and their timestamps in order to
+ determine if a target needs to be rebuild, putting a bunch of
+ functions into one large file is not a good idea since any change
+ to any of those functions will result in that whole file being
+ recompiled. However, one file per function is the other extreme of
+ this. In most software projects related functions comprising some
+ group of related software, a module, is a good compromise between
+ these two extremes.</p>
+
+ <h3>Using Source RPMs</h3>
+
+ <p>One popular construct in the Open Source world is that of
+ source RPMs. RPM stands for Redhat Package Manager and was
+ Redhat's answer to the question of how to install software on a
+ Linux system. But rpm when farther than that to include what it
+ calls Source RPMs. The concept is simple but also beautiful. While
+ an rpm is considered a binary install package a source rpm (AKA
+ rpms) contains all of the source and related other files like
+ makefiles, installation scripts, etc. In short everything is in
+ there for you to build the package from scratch. This is usual on
+ Linux systems as there are many systems on different architectures
+ where a package needs to be compiled before it is installed on the
+ system.</p>
+
+ <p>Many companies are taking Redhat Source RPMs and then modifying
+ only those packages that they wish to change. Other packages are
+ rebuilt from source untouched. This allows developers to
+ essentially build their own complete system with their changes
+ incorporated. A pretty ideal setup - but are RPM Source builds
+ efficient?</p>
+
+ <h3>RPM Source Builds</h3>
+
+ <p>Turns out that RPM source builds are not efficient at all. In
+ most cases everything gets recompiled everytime. One reason for
+ this is that source rpms are distributed as one large
+ file. Another is that a source rpm is really the <b>derived
+ file</b> not the set of source files before compilation. Because
+ of this make's assumptions have been violated and make is forced
+ to recompile everything.<p>
+
+ <p>The rpm -b or rpmbuild execution itself highlights the
+ problem. In the normal execution of rpm -b or rpmbuild the
+ following actions happen:</p>
+
+ <ol>
+ <li>In the %prep section the standard %setup macro's first job
+ is to remove any old copies of the build tree</li>
+
+ <li>The next step of the standard %setup macro is to untar the
+ source from the embedded tarball</li>
+
+ <li>The final step is to cd to the build directory and set
+ permissions appropriately</li>
+ </ol>
+
+ <p>So even before we get a chance to build anything we have a
+ "fresh" environment which is also an environment where make has no
+ chance of doing any build avoidance! Open Source source RPMs that
+ use the %setup macro will always build everything every time.</p>
+
+ <h3>The configure redundancy</h3>
+
+ <p>Additionally most Open Source packages first run configure to
+ interrogate the environment and configure the package so that it
+ can successfully build. In theory it's a good idea. In practice
+ it's slow. Also, each module performs this long configure step
+ again and again. Configure itself is smart enough to create a
+ cache of its findings so running it a second time <b>in the same
+ directory or module</b> will not have to go through all that work
+ again but remember, because of how source rpms work we are always
+ going through configure for the first time. Plus configure does
+ not create the cache for the system as a whole but the module
+ itself. Descend into another directory representing a module and
+ you'll be running configure, again and again...</p>
+ </div>
+
+ <?php copyright ();?>
+</div>
+
+<script language="JavaScript" src="/JavaScript/Menus.js" type="text/javascript"></script>
+v
+</body>
+</html>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+ <title>ClearSCM: Clearcase: Triggers: Remove Empty Branch</title>
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Article.css">
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Code.css">
+ <link rel="stylesheet" type="text/css" media="print" href="/css/Print.css">
+ <link rel="SHORTCUT ICON" href="http://clearscm.com/favicon.ico" type="image/png">
+
+ <!-- Google Analytics
+ <script src="http://www.google-analytics.com/urchin.js" type="text/javascript">
+ </script>
+ <script type="text/javascript">
+ _uacct = "UA-89317-1";
+ urchinTracker ();
+ </script>
+ Google Analytics -->
+
+ <?php
+ include "../php/clearscm.php";
+ menu_css ();
+ ?>
+</head>
+
+<body>
+
+<?php heading ();?>
+
+<div id="page">
+ <div id="content">
+ <?php start_box ("cs5");?>
+ <h2>Remove Empty Branch Trigger</h2>
+
+ <p>This trigger removes the branch and the zero element that is
+ left when a user checks out an element on a branch then cancels
+ the checkout. Normally this causes a branch with only a zero
+ element which is identical to the version from which it was
+ branched. Essentially this empty branch is useless. This trigger
+ prevents that.</p>
+ <?php end_box ();?>
+
+ <?php display_code ("cc/triggers/RemoveEmptyBranch.pl");?>
+ </div>
+ <?php copyright ();?>
+</div>
+
+<script language="JavaScript" src="/JavaScript/Menus.js" type="text/javascript"></script>
+
+</body>
+</html>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+ <title>ClearSCM Inc.</title>
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Article.css">
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Menus.css">
+ <link rel="stylesheet" type="text/css" media="print" href="/css/Print.css">
+ <link rel="SHORTCUT ICON" href="http://clearscm.com/favicon.ico" type="image/png">
+
+ <!-- Google Analytics
+ <script src="http://www.google-analytics.com/urchin.js" type="text/javascript">
+ </script>
+ <script type="text/javascript">
+ _uacct = "UA-89317-1";
+ urchinTracker ();
+ </script>
+ Google Analytics -->
+
+ <?php
+ include "../php/clearscm.php";
+ menu_css ();
+ ?>
+</head>
+
+<body id="homepage">
+<?php heading ();?>
+
+<div id="page">
+ <div id="content">
+ <?php start_box ("cs3");?>
+ <h2>Clearcase</h2>
+ <?php end_box ();?>
+
+ <h3>A Little History</h3>
+
+ <p>Many of our clients utilize IBM Rational Clearcase for their
+ SCM system of course. <abbr title="Often spelled as
+ ClearCase">Clearcase</abbr> is the Cadillac of SCM systems. Born
+ in the old Unix workstation company named Apollo and originating
+ from the <abbr title="Distributed Software Engineering
+ Environment">DSEE</abbr> project when HP bought out Apollo,
+ engineers on DSEE project didn't want to see their beloved DSEE
+ die so they started a company named <font
+ class=standout>Atria</font>.</p>
+
+ <p>Atria did well and was soon bought out by another software
+ company, makers of <font class=standout>Purify</font> - a software
+ product that helps developers find memory leaks in their code.</p>
+
+ <p>Later <font class=standout>Rational</font>, purveyors of many
+ software engineering environments and tools, bought <font
+ class=standout>PureAtria</font> and for many years it was known
+ simply as <font class=standout>Rational Clearcase</font>.
+
+ <p>Finally IBM, seeing the wisedom in the <i>Rational Approach</i>,
+ bought out Rational where Clearcase, Multisite, Clearquest and the
+ rest of the Rational suite of tools reside today.</p>
+
+ <h3>Base Clearcase</h3>
+
+ <p>Base Clearcase is how Clearcase was originally developed. As
+ such it's a full featured, large, complex and flexible SCM
+ system. Many companies still use Base Clearcase and have build
+ their own set of scripts around Base Clearcase to represent,
+ control enforce policies and automate workflow. IBM Rational saw
+ this and decided to collect the various ways that people use
+ Clearcase to come up with UCM. Still developing software is about
+ as varied as designing snowflakes so UCM does not always fit the
+ environment. As such Base Clearcase is still available and used
+ today.</p>
+
+ <h3>Unified Change Management (UCM)</h3>
+
+ <p>Unified Change Management is a layer built on Base
+ Clearcase to provide additional Software Configuration Management
+ features. These changes include integration with ClearQuest to
+ enforce defect and change tracking with code development through
+ the use of activities. This is part of the Rational Unified
+ Process (RUP) which describes the lifecycle of change management
+ for IBM Rational's software development process. It also gives
+ integrators ownership of projects and streams to allow policy and
+ feature management by project leaders and release engineers. UCM
+ removes the ability/requirement that users manage a configuration
+ specification for a view. UCM is used and configured via either
+ CLIs or GUIs.
+
+ <h3>Multisite</h3>
+
+ <p>Multisite enables fast, reliable access to software assets
+ across distributed locations. This extends software configuration
+ management across geographically distributed projects through
+ repository replication. This gives you the following benefits:</p>
+
+ <ul>
+ <li>Automatic replication and synchronization of Rational
+ Clearcase repositories enables access to current information,
+ regardless of location</li>
+
+ <li>Simplifies administration with an easy-to-use Web-based
+ interface</li>
+
+ <li>Maintains data integrity by resending information in the
+ event of network failure and automatic recovery of repositories
+ in the event of system failure</li>
+
+ <li>Works with Clearquest® Multisite for integrated workflow
+ management and defect and change tracking across multiple
+ locations and time zones</li>
+
+ <li>Scales to support thousands of users, working in dozens of
+ sites, managing terabytes of data<li>
+ </ul>
+ </div>
+
+ <?php copyright ();?>
+</div>
+
+<script language="JavaScript" src="/JavaScript/Menus.js" type="text/javascript"></script>
+
+</body>
+</html>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+ <title>ClearSCM: Triggers</title>
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Article.css">
+ <link rel="stylesheet" type="text/css" media="print" href="/css/Print.css">
+ <link rel="SHORTCUT ICON" href="http://clearscm.com/favicon.ico" type="image/png">
+
+ <!-- Google Analytics
+ <script src="http://www.google-analytics.com/urchin.js" type="text/javascript">
+ </script>
+ <script type="text/javascript">
+ _uacct = "UA-89317-1";
+ urchinTracker ();
+ </script>
+ Google Analytics -->
+
+ <?php
+ include "../php/clearscm.php";
+ menu_css ();
+ ?>
+</head>
+
+<body id="homepage">
+<?php heading ();?>
+
+<div id="page">
+ <div id="content">
+ <?php start_box ("cs5")?>
+ <h2>Clearcase Triggers and Utilities</h2>
+ <?php end_box ();?>
+
+ <p>Many of our consultants have served as Clearcase
+ administrators. Along the way we have often developed scripts for
+ out clients. It doesn't take long to realize that often you're
+ doing the same thing over and over again. This page is a way of
+ pulling together and documenting these scripts.</p>
+
+ <h3><a name="triggers"></a>Triggers</h3>
+
+ <p>Clearcase has triggers which are scripts that are executed when
+ certain Clearcase operations happen. There are some comon ones and
+ some not to common ones. Here are some of them.</p>
+
+ <ul>
+ <li><a href="EvilTwin.php">Evil Twin Trigger</a>: Prevents the
+ creation of <i>Evil Twins</i>.
+
+ <li><a href="RemoveEmptyBranch.php">Remove Empty Branch</a>:
+ Removes empty branches.</p>
+
+ <li><a name="mktriggers"></a><a
+ href="/php/cvs_man.php?file=cc/mktriggers.pl">mktriggers.pl</a>: Make triggers.</li>
+ </ul>
+ </div>
+
+ <?php copyright ();?>
+</div>
+
+<script language="JavaScript" src="/JavaScript/Menus.js" type="text/javascript"></script>
+
+</body>
+</html>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+
+ <title>ClearSCM: Clearquest: CheckCodePage.pl</title>
+
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Article.css">
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Code.css">
+ <link rel="stylesheet" type="text/css" media="print" href="/css/Print.css">
+ <link rel="SHORTCUT ICON" href="http://clearscm.com/favicon.ico" type="image/png">
+
+ <!-- Google Analytics
+ <script src="http://www.google-analytics.com/urchin.js" type="text/javascript">
+ </script>
+ <script type="text/javascript">
+ _uacct = "UA-89317-1";
+ urchinTracker ();
+ </script>
+ Google Analytics -->
+
+ <?php
+ include "../php/clearscm.php";
+ menu_css ();
+ ?>
+</head>
+
+<body>
+
+<?php heading ();?>
+
+<div id="page">
+ <div id="content">
+ <?php start_box ("cs5");?>
+ <h2>CheckCodePage.pl</h2>
+ <p>Checks to see if there are any non US ASCII characters in
+ the database fields </p>
+ <?php end_box ();?>
+
+ <?php display_code ("cq/CheckCodePage.pl");?>
+ </div>
+ <?php copyright ();?>
+</div>
+
+<script language="JavaScript" src="/JavaScript/Menus.js" type="text/javascript"></script>
+
+</body>
+</html>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+
+ <title>ClearSCM: Clearquest: pqamerge: PQA.pm</title>
+
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Article.css">
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Code.css">
+ <link rel="stylesheet" type="text/css" media="print" href="/css/Print.css">
+ <link rel="SHORTCUT ICON" href="http://clearscm.com/favicon.ico" type="image/png">
+
+ <!-- Google Analytics
+ <script src="http://www.google-analytics.com/urchin.js" type="text/javascript">
+ </script>
+ <script type="text/javascript">
+ _uacct = "UA-89317-1";
+ urchinTracker ();
+ </script>
+ Google Analytics -->
+
+ <?php
+ include "../php/clearscm.php";
+ menu_css ();
+ ?>
+</head>
+
+<body>
+
+<?php heading ();?>
+
+<div id="page">
+ <div id="content">
+ <?php start_box ("cs5");?>
+ <h2>pqamerge</h2>
+ <p>Perl Module to hold common routines</p>
+ <?php end_box ();?>
+
+ <?php display_code ("cq/PQA.pm");?>
+ </div>
+ <?php copyright ();?>
+</div>
+
+<script language="JavaScript" src="/JavaScript/Menus.js" type="text/javascript"></script>
+
+</body>
+</html>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+
+ <title>ClearSCM: Clearquest: check_attachments</title>
+
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Article.css">
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Code.css">
+ <link rel="stylesheet" type="text/css" media="print" href="/css/Print.css">
+ <link rel="SHORTCUT ICON" href="http://clearscm.com/favicon.ico" type="image/png">
+
+ <!-- Google Analytics
+ <script src="http://www.google-analytics.com/urchin.js" type="text/javascript">
+ </script>
+ <script type="text/javascript">
+ _uacct = "UA-89317-1";
+ urchinTracker ();
+ </script>
+ Google Analytics -->
+
+ <?php
+ include "../php/clearscm.php";
+ menu_css ();
+ ?>
+</head>
+
+<body>
+
+<?php heading ();?>
+
+<div id="page">
+ <div id="content">
+ <?php start_box ("cs5");?>
+ <h2>check_attachments</h2>
+ <p>Checks to make sure that the size of the attachments added
+ up after the merge</p>
+ <?php end_box ();?>
+
+ <?php display_code ("cq/check_attachments");?>
+ </div>
+ <?php copyright ();?>
+</div>
+
+<script language="JavaScript" src="/JavaScript/Menus.js" type="text/javascript"></script>
+
+</body>
+</html>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+
+ <title>ClearSCM: Clearquest: Deamon: CQD</title>
+
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Article.css">
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Code.css">
+ <link rel="stylesheet" type="text/css" media="print" href="/css/Print.css">
+ <link rel="SHORTCUT ICON" href="http://clearscm.com/favicon.ico" type="image/png">
+
+ <!-- Google Analytics
+ <script src="http://www.google-analytics.com/urchin.js" type="text/javascript">
+ </script>
+ <script type="text/javascript">
+ _uacct = "UA-89317-1";
+ urchinTracker ();
+ </script>
+ Google Analytics -->
+
+ <?php
+ include "../../php/clearscm.php";
+ menu_css ();
+ ?>
+</head>
+
+<body>
+
+<?php heading ();?>
+
+<div id="page">
+ <div id="content">
+ <?php start_box ("cs5");?>
+ <h2>Checkin Trigger (code)</h2>
+
+ <p>Trigger for checkins that utilizes the CQD API</p>
+ <?php end_box ();?>
+
+ <?php display_code ("cq/cqd/CheckinPreop.pl");?>
+ </div>
+ <?php copyright ();?>
+</div>
+
+<script language="JavaScript" src="/JavaScript/Menus.js" type="text/javascript"></script>
+
+</body>
+</html>
--- /dev/null
+
+<?xml version="1.0" encoding="iso-8859-1"?>
+<!DOCTYPE html
+ PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
+ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US" xml:lang="en-US"><head><title>Release 2.3.0.1</title>
+<link rev="made" href="mailto:Andrew%40DeFaria.com" />
+<script src="/Javascript/Heading.js" type="text/javascript"></script>
+</head><body link="#0000ee" alink="#ff0000" vlink="#cc33cc" bgcolor="#eeffff" text="#000000"><p align="right"><a href="/Release/addbug">Add a bug to a release</a>
+<br><a href="file://///sons-clearcase/Views/official/Tools/bin/clearcase/triggers/data/rel_2.2.lst">Official US 2.2 list</a>
+<br><a href="file://///sons-cc/Views/official/Tools/bin/clearcase/triggers/data/china_2.2.lst">Official Shanghai 2.2 list</a></br></br></p>
+<h1 align="CENTER">Release 2.3.0.1</h1>
+<h2>Introduction</h2>
+<ul><li><font color=Blue>Closed 01/26/2004 @ 12:00 Pm</font></li>
+</ul>
+<table cellpadding=0 cellspacing=1 border=0 width=95% align=center bgcolor=Black>
+<caption><small><strong>6 bugs in this release</strong></small></caption>
+<tbody><tr><td valign=top>
+<table border="1" align="center" cellpadding="2" cellspacing="1" width="100%">
+<tr bgcolor="#ffffcc" valign="top"><th width="25"><font color="#000000"><small>#</small></font></th><th><font color="#000000"><small>Bug ID</small></font></th><th><font color="#000000"><small>State</small></font></th><th><font color="#000000"><small>Owner</small></font></th><th><font color="#000000"><small>Locked?</small></font></th><th><font color="#000000"><small>Description</small></font></th></tr>
+<tr valign="TOP"><td bgcolor="#ffffff" align="center" width="25"><small>1</small></td><td bgcolor="#ffffff"><small><a href="/cgi-bin/bugdetails.cgi?bugid=BUGS200003541">BUGS200003541</a></small></td><td bgcolor="#ffffff"><small>Closed</small></td><td bgcolor="#ffffff" align="center"><small><a href="mailto:yxiu@salira.com">yxiu</a></small></td><td bgcolor="#ffffff" align="center" valign="center"><img src="/Images/CheckMark.gif" /></td><td bgcolor="#ffffff"><small>Flash driver: improve exit code</small></td>
+</tr> <tr valign="TOP"><td bgcolor="#ffffff" align="center" width="25"><small>2</small></td><td bgcolor="#ffffff"><small><a href="/cgi-bin/bugdetails.cgi?bugid=BUGS200003544">BUGS200003544</a></small></td><td bgcolor="#ffffff"><small>Closed</small></td><td bgcolor="#ffffff" align="center"><small><a href="mailto:dko@salira.com">dko</a></small></td><td bgcolor="#ffffff" align="center" valign="center"><img src="/Images/CheckMark.gif" /></td><td bgcolor="#ffffff"><small>Check in: IGMP should provide groupid lookup function for SAL</small></td>
+</tr> <tr valign="TOP"><td bgcolor="#ffffff" align="center" width="25"><small>3</small></td><td bgcolor="#ffffff"><small><a href="/cgi-bin/bugdetails.cgi?bugid=BUGS200003558">BUGS200003558</a></small></td><td bgcolor="#ffffff"><small>Closed</small></td><td bgcolor="#ffffff" align="center"><small><a href="mailto:gtsang@salira.com">gtsang</a></small></td><td bgcolor="#ffffff" align="center" valign="center"><img src="/Images/CheckMark.gif" /></td><td bgcolor="#ffffff"><small>IGMP fast start feature</small></td>
+</tr> <tr valign="TOP"><td bgcolor="#ffffff" align="center" width="25"><small>4</small></td><td bgcolor="#ffffff"><small><a href="/cgi-bin/bugdetails.cgi?bugid=BUGS200003559">BUGS200003559</a></small></td><td bgcolor="#ffffff"><small>Closed</small></td><td bgcolor="#ffffff" align="center"><small><a href="mailto:shou@salira.com">shou</a></small></td><td bgcolor="#ffffff" align="center" valign="center"><img src="/Images/CheckMark.gif" /></td><td bgcolor="#ffffff"><small>WebSAM: Cannot create VLAN's</small></td>
+</tr> <tr valign="TOP"><td bgcolor="#ffffff" align="center" width="25"><small>5</small></td><td bgcolor="#ffffff"><small><a href="/cgi-bin/bugdetails.cgi?bugid=BUGS200003547">BUGS200003547</a></small></td><td bgcolor="#ffffff"><small>Closed</small></td><td bgcolor="#ffffff" align="center"><small><a href="mailto:dko@salira.com">dko</a></small></td><td bgcolor="#ffffff" align="center" valign="center"><img src="/Images/CheckMark.gif" /></td><td bgcolor="#ffffff"><small>igmp_getProxyStats Exception</small></td>
+</tr> <tr valign="TOP"><td bgcolor="#ffffff" align="center" width="25"><small>6</small></td><td bgcolor="#ffffff"><small><a href="/cgi-bin/bugdetails.cgi?bugid=BUGS200003568">BUGS200003568</a></small></td><td bgcolor="#ffffff"><small>Closed</small></td><td bgcolor="#ffffff" align="center"><small><a href="mailto:zlou@salira.com">zlou</a></small></td><td bgcolor="#ffffff" align="center" valign="center"><img src="/Images/CheckMark.gif" /></td><td bgcolor="#ffffff"><small>SAL support multicasting service dynamic activation</small></td>
+</tr>
+</table>
+</table><form method="post" action="/Release/releasenotes.cgi" enctype="application/x-www-form-urlencoded">
+<h4>Look up other Release: <input type="text" name="release" value="2.3.0.1" size="12" /> <input type="submit" name=".submit" value="Display" /></h4><div></div>
+</form>
+<script src="/JavaScript/Footing.js" language="JavaScript1.2" />
+</body></html>
\ No newline at end of file
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+
+ <title>ClearSCM: Clearquest: Deamon: CQD</title>
+
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Article.css">
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Code.css">
+ <link rel="stylesheet" type="text/css" media="print" href="/css/Print.css">
+ <link rel="SHORTCUT ICON" href="http://clearscm.com/favicon.ico" type="image/png">
+
+ <!-- Google Analytics
+ <script src="http://www.google-analytics.com/urchin.js" type="text/javascript">
+ </script>
+ <script type="text/javascript">
+ _uacct = "UA-89317-1";
+ urchinTracker ();
+ </script>
+ Google Analytics -->
+
+ <?php
+ include "../../php/clearscm.php";
+ menu_css ();
+ ?>
+</head>
+
+<body>
+
+<?php heading ();?>
+
+<div id="page">
+ <div id="content">
+ <?php start_box ("cs5");?>
+ <h2>Clearquest Client</h2>
+
+ <p>Implements a client to test the daemon as well as provides a
+ flexible command line interface for quick queries about
+ Clearquest defects.</p>
+ <?php end_box ();?>
+
+ <?php display_code ("cq/cqd/cqc");?>
+ </div>
+ <?php copyright ();?>
+</div>
+
+<script language="JavaScript" src="/JavaScript/Menus.js" type="text/javascript"></script>
+
+</body>
+</html>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+
+ <title>ClearSCM: Clearquest: Deamon: CQD</title>
+
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Article.css">
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Code.css">
+ <link rel="stylesheet" type="text/css" media="print" href="/css/Print.css">
+ <link rel="SHORTCUT ICON" href="http://clearscm.com/favicon.ico" type="image/png">
+
+ <!-- Google Analytics
+ <script src="http://www.google-analytics.com/urchin.js" type="text/javascript">
+ </script>
+ <script type="text/javascript">
+ _uacct = "UA-89317-1";
+ urchinTracker ();
+ </script>
+ Google Analytics -->
+
+ <?php
+ include "../../php/clearscm.php";
+ menu_css ();
+ ?>
+</head>
+
+<body>
+
+<?php heading ();?>
+
+<div id="page">
+ <div id="content">
+ <?php start_box ("cs5");?>
+ <h2>Clearquest Daemon API (code)</h2>
+
+ <p>Defines the API to the Clearquest Daemon.</p>
+ <?php end_box ();?>
+
+ <?php display_code ("cq/cqd/cqc.pm");?>
+ </div>
+ <?php copyright ();?>
+</div>
+
+<script language="JavaScript" src="/JavaScript/Menus.js" type="text/javascript"></script>
+
+</body>
+</html>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+
+ <title>ClearSCM: Clearquest: Deamon: CQD</title>
+
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Article.css">
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Code.css">
+ <link rel="stylesheet" type="text/css" media="print" href="/css/Print.css">
+ <link rel="SHORTCUT ICON" href="http://clearscm.com/favicon.ico" type="image/png">
+
+ <!-- Google Analytics
+ <script src="http://www.google-analytics.com/urchin.js" type="text/javascript">
+ </script>
+ <script type="text/javascript">
+ _uacct = "UA-89317-1";
+ urchinTracker ();
+ </script>
+ Google Analytics -->
+
+ <?php
+ include "../../php/clearscm.php";
+ menu_css ();
+ ?>
+</head>
+
+<body>
+
+<?php heading ();?>
+
+<div id="page">
+ <div id="content">
+ <?php start_box ("cs5");?>
+ <h2>Clearquest Daemon</h2>
+
+ <p>Implements a daemon which services requests for information
+ about Clearquest defects.</p>
+ <?php end_box ();?>
+
+ <?php display_code ("cq/cqd/cqd");?>
+ </div>
+ <?php copyright ();?>
+</div>
+
+<script language="JavaScript" src="/JavaScript/Menus.js" type="text/javascript"></script>
+
+</body>
+</html>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+
+ <title>ClearSCM: Clearquest: Daemon</title>
+
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Article.css">
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Code.css">
+ <link rel="stylesheet" type="text/css" media="print" href="/css/Print.css">
+ <link rel="SHORTCUT ICON" href="http://clearscm.com/favicon.ico" type="image/png">
+
+ <!-- Google Analytics
+ <script src="http://www.google-analytics.com/urchin.js" type="text/javascript">
+ </script>
+ <script type="text/javascript">
+ _uacct = "UA-89317-1";
+ urchinTracker ();
+ </script>
+ Google Analytics -->
+
+ <?php
+ include "../../php/clearscm.php";
+ menu_css ();
+ ?>
+</head>
+
+<body id="homepage">
+<?php heading ();?>
+
+<div id="page">
+ <div id="content">
+ <?php start_box ("cs3");?>
+ <h2>Clearquest Daemon</h2>
+ <?php end_box ();?>
+
+ <h3>Overview</h3>
+
+ <p>At a previous company I was asked to provide a mechanism for
+ <i>controlled checkins</i> of code into release branches. It was
+ decided not to use <font class="standout">Rational's UCM
+ Model</font> since the company was small and it's needs were
+ simple. Additionally the company wanted to be able to produce
+ <i>Release Notes</i> depicting which bugs were fixed in the release
+ in an automated fashion. They did not want to incur significant
+ overhead when checking in code and wanted to tightly control which
+ bugs went into which release branch.</p>
+
+ <?php start_box ("cs2");?>
+ <b>Problem Statement:</b> Provide a mechanism for <u>controlled
+ checkins</u> and a way to automate Release Notes for releases.
+ <?php end_box ();?>
+
+ <h3>Environment</h3>
+
+ <p>The environment of this company was as follows:</p>
+
+ <ul>
+ <li>Small company - ~30 Engineers in Santa Clara, USA and ~20 in
+ Shanghai, China</li>
+
+ <li>All Windows shop</li>
+
+ <li>Rational Clearcase LT</li>
+
+ <li>Rational Clearquest</li>
+
+ <li>Rational Multisite</li>
+
+ <li>One main server serving both Clearcase and Clearquest</li>
+
+ <li>Slow VPN WAN to Shanghai</li>
+ </ul>
+
+ <p>Multisite and the Shanhai office were not initially rolled out
+ but the design considered them nonetheless. Unfortunately
+ Multisiting of the Clearquest database was ruled out as too
+ expensive for our little startup company.</p>
+
+ <h3>Requirements</h3>
+
+ <p>The requirements for this Clearcase/Clearquest integration were as follows:
+
+ <ul>
+ <li>Verify that all elements checked into a release branch were associated with
+ a Clearquest defect intended for that release.</li>
+
+ <li>Verify the defect was:
+
+ <ul>
+ <li>Owned</li>
+
+ <li>Only in certain states (Must be in <font class="standout">Assigned</font>
+ or <font class="standout">Resolved</font>).</li>
+
+ <li>On <i>the list</i> of defects for this release.</li>
+
+ <li>Different release branches will have different <i>lists</i>.</li>
+ </ul>
+
+ <li>Allow for some branches to not require a defect number while
+ those releases were in a state of "development".</li>
+
+ <li>Defect numbers will be entered by the engineers as part of the
+ comment. This process should allow multiple defect numbers per
+ checkin.</li>
+
+ <li>Provide a way to lock out checkins of defects for building.</li>
+
+ <li>Provide a way to generate Release Notes for a release based on
+ the defects fixed.</li>
+
+ </ul>
+
+ <h3>Assumptions</h3>
+
+ <p>There were certain assumptions and other processes already put into place
+ that assisted in the solution.</p>
+
+ <ul>
+ <li>All checkins that required a bug ID would have a label applied to them
+ that consisted of the bug ID.</li>
+
+ <li>When engineers were done checking in these labels would be locked so
+ that further checkins for this bug were stopped.</li>
+
+ <li>Engineers would be allowed to continue to work on the release branch
+ while the release was building</li>
+ </ul>
+
+ <h3>Check In Trigger</h3>
+
+ <ul>
+ <li><i>Controlled checkins</i> would be done through a check in
+ trigger that would make sure that the conditions were right to
+ allow checkin to proceed.</li>
+
+ <li>In order to retrieve data from Clearquest CQPerl was used.</li>
+
+ <li>Initial testing of this trigger showed that it took a very
+ long time to connect to the Clearquest database only to retrieve a
+ bit of information. If many elements were to be checked in the
+ opening and closing of the database made the checkins take
+ a long time!
+
+ <li>Our sister lab in Shanghai, China would also participate in
+ this process therefore the trigger must also must minimize wait
+ time over the WAN.</li>
+
+ </ul>
+
+ <p>A better method was needed<blink>...</blink></p>
+
+ <img src="BeforeCQD.jpg" border=0>
+
+ <h3>Daemon</h3>
+
+ <ul>
+ <li>In order to minimize database open/close times a daemon was
+ developed that would hold the Clearquest database open and respond
+ to requests for information through a socket.</li>
+
+ <li>The daemon would return information about a bug ID to the
+ caller. This drastically sped up the process for the Checkin
+ Trigger.</li>
+
+ <li>Additionally this general purpose daemon could be used in
+ other ways (e.g. Web Page Based Release Notes).</li>
+ </ul>
+
+ <img src="CQD.jpg" border=0>
+
+ <h3>CQPerl Problems</h3>
+
+ <p>A good daemon process:</p>
+
+ <ul>
+ <li>Puts itself into <i>Daemon mode</i></li>
+
+ <li>Is <font class="standout">Multithreaded</font>. This means
+ that it responds to a request and forks a child process off to
+ handle the request so that the parent process can accept the next
+ client.</li>
+ </ul>
+
+ <p>Since, at the time, CQPerl was the only supported way to
+ interface with Clearquest it had to be used. Because CQPerl is based
+ off of ActiveState Perl a number of problems arose:</p>
+
+ <ol>
+ <li>ActiveState Perl does <b>not</b> support calling <font
+ class="standout">setsid</font> which is required to enter
+ <i>Daemon mode</i>.</li>
+
+ <li>ActiveState Perl does not reliably handle signals. This mean
+ that the parent process could not reliably catch <font
+ class="standout">SIGCLD</font> deaths</li>
+ </ol>
+
+ <p>As a result the Clearquest Daemon Process is <font
+ class="standout">not</font> multithreaded. Since the company
+ is small and requests relatively infrequent this was an acceptable
+ limitation. Still when processing large lists of Release Notes and
+ over the WAN the service would, at times, be unavailable.</p>
+
+ <h3>SetSID</h3>
+
+ <p>The question remained then, <b>How does one go into daemon mode?</b></p>
+
+ <p>Here I resorted to using something that the company was already
+ using - <a href="http://cygwin.com">Cygwin</a>.</p>
+
+ <p>Cygwin is a Linux emulation running under Windows. It is one of
+ the most complete emulations I have found. We used it to build
+ (gnumake) as well as many other things.</p>
+
+ <p>Cygwin has a program called cygrunsrv which allows you to
+ daemonize any other process.</p>
+
+ <h3>Multithreading</h3>
+
+ <p>The problem with making the server multithreaded was harder to
+ resolve. Code was written to perform multithreading but the
+ unreliability of signal handling proved to be a problem that could
+ not be easily overcome.</p>
+
+ <p>Options for a multithreading included:</p>
+
+ <ul>
+ <li>Figure out how to handle signals properly under ActiveState
+ Perl. Research was done on ActiveState's forums and eventually the
+ engineer for ActiveState Perl said that signals just can't be
+ reliably done under Windows.</li>
+
+ <li>Rewrite code into another language. The client/server could
+ have been rewritten into another language that supported
+ multithreading however much work had already been done on the
+ daemon and a few clients, also written in Perl, would need to also
+ be rewritten or interfaced to this other language</li>
+ </ul>
+
+
+ <p>In the end it was decided since the demand on the server would not
+ be that great, that a single threaded server would suffice.</p>
+
+ <h3>Client/Server</h3>
+
+ <?php start_box ("cs3");?>
+ <b>In depth:</b> Code listings for <a href="cqd.php">CQD
+ Daemon</a>, <a href="cqc.php">CQC Client</a> and <a
+ href="cqc.pm.php">cqc.pm</a>
+ <?php end_box ();?>
+
+ <p>Since this is a client server application the <a href="cqd.php">CQD Daemon</a>
+ was written as well as a <a href="cqc.php">CQC Client</a>. A Perl module named
+ <a href="cqc.pm.php">cqc.pm</a> was made to define the API for CDQ.</p>
+
+ <p>The test client, CQC, ended up being a useful command line tool
+ to get information about a bug from Clearquest. A user could, for
+ example, obtain the owner of a bug by simply doing:</p>
+
+ <div class="code"><pre>
+ $ cqc 1234 owner
+ swang
+ $ cqc 1322 owner headline
+ owner: jliu
+ headline: Unable to modify ACLS that are created (observed during ACL tests)
+ $
+ </pre></div>
+
+ <h3>Trigger</h3>
+
+ <?php start_box ("cs3");?>
+ <b>In depth:</b> Code listing for <a href="CheckinPreop.php">Check
+ in Trigger</a>.
+ <?php end_box ();?>
+
+ <p>A preop <i>Checkin Trigger</i> was created to:</p>
+
+ <ul>
+ <li>Make sure that a comment was specified</li>
+
+ <li>Extract all bug IDs from the comment</li>
+
+ <li>If the check in was on a release branch requiring bug ID checkin then
+ the trigger would make sure:</li>
+
+ <ul>
+ <li>The bug ID existed in Clearquest, was owned and in the
+ proper state.</li>
+
+ <li>The bug ID label was not locked.</li>
+
+ <li>The bug ID was listed in a file for that release branch
+ (i.e. <release branch>.lst)</li>
+ </ul>
+ </ul>
+
+ <p>A postop <i>Checkin Trigger</i> would then create labels for the
+ bug IDs and apply those labels to the checked in elements.</p>
+
+ <h3>Release Notes</h3>
+
+ <?php start_box ("cs3");?>
+ <b>In depth:</b> Code listing for <a href="rn.php">Releasenote CGI
+ Script</a>.
+ <?php end_box ();?>
+
+ <p>With the Clearquest Daemon satisifying requests and with the
+ Checkin Trigger already relying on a flat file of bug IDs for a
+ release, generating a web page of release notes merely involved some
+ ordinary formatting of a web page and a calling of the daemon to
+ supply Clearquest information in a tabular format.</p>
+
+ <p>Additionally web pages were created to allow addition of bug IDs
+ to the release list</p>
+
+ <p>Since CQD returns all fields in the defect record a web page
+ showing all details of a defect was also developed</p>
+
+ <p>And example of Release notes is shown <a
+ href="Releasenotes.html">here</a>.</p>
+
+</div>
+
+ <?php copyright ();?>
+</div>
+
+<script language="JavaScript" src="/JavaScript/Menus.js" type="text/javascript"></script>
+
+</body>
+</html>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+
+ <title>ClearSCM: Clearquest: Deamon: CQD</title>
+
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Article.css">
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Code.css">
+ <link rel="stylesheet" type="text/css" media="print" href="/css/Print.css">
+ <link rel="SHORTCUT ICON" href="http://clearscm.com/favicon.ico" type="image/png">
+
+ <!-- Google Analytics
+ <script src="http://www.google-analytics.com/urchin.js" type="text/javascript">
+ </script>
+ <script type="text/javascript">
+ _uacct = "UA-89317-1";
+ urchinTracker ();
+ </script>
+ Google Analytics -->
+
+ <?php
+ include "../../php/clearscm.php";
+ menu_css ();
+ ?>
+</head>
+
+<body>
+
+<?php heading ();?>
+
+<div id="page">
+ <div id="content">
+ <?php start_box ("cs5");?>
+ <h2>Releasenotes.cgi Code Listing</h2>
+ <?php end_box ();?>
+
+ <?php display_code ("cq/cqd/releasenotes.cgi");?>
+ </div>
+ <?php copyright ();?>
+</div>
+
+<script language="JavaScript" src="/JavaScript/Menus.js" type="text/javascript"></script>
+
+</body>
+</html>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+
+ <title>ClearSCM: Clearquest</title>
+
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Article.css">
+ <link rel="stylesheet" type="text/css" media="print" href="/css/Print.css">
+ <link rel="SHORTCUT ICON" href="http://clearscm.com/favicon.ico" type="image/png">
+
+ <!-- Google Analytics
+ <script src="http://www.google-analytics.com/urchin.js" type="text/javascript">
+ </script>
+ <script type="text/javascript">
+ _uacct = "UA-89317-1";
+ urchinTracker ();
+ </script>
+ Google Analytics -->
+
+ <?php
+ include "../php/clearscm.php";
+ menu_css ();
+ ?>
+</head>
+
+<body id="homepage">
+<?php heading ();?>
+
+<div id="page">
+ <div id="content">
+ <?php start_box ("cs3");?>
+ <h2>Clearquest</h2>
+ <?php end_box ();?>
+
+ <p>There are many times when we have written custom code to
+ interact with Clearquest databases. Below are links to some of the
+ code we have developed over the years.</p>
+
+ <p>At one client, we had written a <a
+ href="/clearquest/cqd">Clearquest Daemon</a>, a daemon process
+ that maintained a connection to a Clearquest database and serviced
+ requests for information about Clearquest defects.</p>
+
+ <p>Other Perl scripts had been developed for a client to merge
+ together two similar, yet different, Clearquest databases into a
+ new combined database. This script, <a
+ href="pqamerge.php">pqamerge</a> does just that. Obviously such
+ conversions and merges are very specific to the customer at
+ hand. Still this script serves to show how to interact with the
+ Clearquest API to perform such actions.</p>
+
+ <p>The pqamerge script, while it did perform the merge in general,
+ also had a few side scripts that were useful when performing this
+ merge:</p>
+
+ <ul>
+ <li><a href="PQA.pm.php">PQA.pm</a>: Perl Module to hold common
+ routines</li>
+
+ <li><a href="pqamerge.php">pqamerge</a>: Main script - performs
+ the merge</li>
+
+ <li><a href="pqaclean.php">pqaclean</a>: Cleans up by removing
+ all records from the destination database as well as removing
+ all Dynamic Lists.</li>
+
+ <li><a href="CheckCodePage.php">CheckCodePage.pl</a>: Checks to
+ see if there are any non US ASCII characters in the database
+ fields</li>
+
+ <li><a href="check_attachments.php">check_attachments</a>:
+ Checks to make sure that the size of the attachments added up
+ after the merge</li>
+
+ <li><a href="listdynlists.php">listdynlist</a>: Lists Dynamic
+ Lists present in the database</li>
+
+ <li><a href="enable_ldap.php">enable_ldap</a>: Prompts for the
+ data necessary to enable LDAP Authentication in Clearquest and
+ issues the necessary installutil commands to enable LDAP. Reads
+ data from a config file.</li>
+ </ul>
+ </div>
+
+ <?php copyright ();?>
+</div>
+
+<script language="JavaScript" src="/JavaScript/Menus.js" type="text/javascript"></script>
+
+</body>
+</html>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+
+ <title>ClearSCM: Clearquest: Enable LDAP</title>
+
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Article.css">
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Code.css">
+ <link rel="stylesheet" type="text/css" media="print" href="/css/Print.css">
+ <link rel="SHORTCUT ICON" href="http://clearscm.com/favicon.ico" type="image/png">
+
+ <!-- Google Analytics
+ <script src="http://www.google-analytics.com/urchin.js" type="text/javascript">
+ </script>
+ <script type="text/javascript">
+ _uacct = "UA-89317-1";
+ urchinTracker ();
+ </script>
+ Google Analytics -->
+
+ <?php
+ include "../php/clearscm.php";
+ menu_css ();
+ ?>
+</head>
+
+<body>
+
+<?php heading ();?>
+
+<div id="page">
+ <div id="content">
+ <?php start_box ("cs5");?>
+ <h2>enable_ldap</h2>
+ <p>This script prompts for the data necessary to enable LDAP
+ authentication in Clearquest and issue the necessary
+ installutil commands to enable LDAP. Reads data from a config
+ file.</p>
+ <?php end_box ();?>
+
+ <?php display_code ("cq/enable_ldap");?>
+ </div>
+ <?php copyright ();?>
+</div>
+
+<script language="JavaScript" src="/JavaScript/Menus.js" type="text/javascript"></script>
+
+</body>
+</html>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+
+ <title>ClearSCM: Clearquest</title>
+
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Article.css">
+ <link rel="stylesheet" type="text/css" media="print" href="/css/Print.css">
+ <link rel="SHORTCUT ICON" href="http://clearscm.com/favicon.ico" type="image/png">
+
+ <!-- Google Analytics
+ <script src="http://www.google-analytics.com/urchin.js" type="text/javascript">
+ </script>
+ <script type="text/javascript">
+ _uacct = "UA-89317-1";
+ urchinTracker ();
+ </script>
+ Google Analytics -->
+
+ <?php
+ include "../php/clearscm.php";
+ menu_css ();
+ ?>
+</head>
+
+<body id="homepage">
+<?php heading ();?>
+
+<div id="page">
+ <div id="content">
+ <?php start_box ("cs3");?>
+ <h2>Clearquest</h2>
+ <?php end_box ();?>
+
+ <p>There are many times when we have written custom code to
+ interact with Clearquest databases. Below are links to some of the
+ code we have developed over the years.</p>
+
+ <p>At one client, we had written a <a
+ href="/clearquest/cqd">Clearquest Daemon</a>, a daemon process
+ that maintained a connection to a Clearquest database and serviced
+ requests for information about Clearquest defects.</p>
+
+ <p>Other Perl scripts had been developed for a client to merge
+ together two similar, yet different, Clearquest databases into a
+ new combined database. This script, <a
+ href="pqamerge.php">pqamerge</a> does just that. Obviously such
+ conversions and merges are very specific to the customer at
+ hand. Still this script serves to show how to interact with the
+ Clearquest API to perform such actions.</p>
+
+ <p>The pqamerge script, while it did perform the merge in general,
+ also had a few side scripts that were useful when performing this
+ merge:</p>
+
+ <ul>
+ <li><a href="PQA.pm.php">PQA.pm</a>: Perl Module to hold common
+ routines</li>
+
+ <li><a href="pqamerge.php">pqamerge</a>: Main script - performs
+ the merge</li>
+
+ <li><a href="pqaclean.php">pqaclean</a>: Cleans up by removing
+ all records from the destination database as well as removing
+ all Dynamic Lists.</li>
+
+ <li><a href="CheckCodePage.php">CheckCodePage.pl</a>: Checks to
+ see if there are any non US ASCII characters in the database
+ fields</li>
+
+ <li><a href="check_attachments.php">check_attachments</a>:
+ Checks to make sure that the size of the attachments added up
+ after the merge</li>
+
+ <li><a href="listdynlists.php">listdynlist</a>: Lists Dynamic
+ Lists present in the database</li>
+
+ <li><a href="enable_ldap.php">enable_ldap</a>: Prompts for the
+ data necessary to enable LDAP Authentication in Clearquest and
+ issues the necessary installutil commands to enable LDAP. Reads
+ data from a config file.</li>
+ </ul>
+ </div>
+
+ <?php copyright ();?>
+</div>
+
+<script language="JavaScript" src="/JavaScript/Menus.js" type="text/javascript"></script>
+
+</body>
+</html>
--- /dev/null
+#################################################################################
+#
+# File: ldap_settings.cfg
+# Description: Describes the various LDAP parameters
+# Author: Andrew@DeFaria.com
+# Created: Wed Nov 2 11:19:04 PST 2005
+# Language: None
+#
+# (c) Copyright 2005, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+DBSet: 2005.02.00
+Admin_username: admin
+#Admin_password:
+Servers: server.clearscm.com
+Port: 389
+Search_distinguished_name: <deistinguished_name>
+#Search_password:
+BaseDN: <BaseDN>
+Scope: sub
+Account_attribute: samAccountName
+Search_filter: samAccountName=%login%
+CQ_field: CQ_LOGIN_NAME
+attribute_search_entry: samAccountName
+Test_username: <username>
+Test_password: <password>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+
+ <title>ClearSCM: Clearquest: listdynlists</title>
+
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Article.css">
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Code.css">
+ <link rel="stylesheet" type="text/css" media="print" href="/css/Print.css">
+ <link rel="SHORTCUT ICON" href="http://clearscm.com/favicon.ico" type="image/png">
+
+ <!-- Google Analytics
+ <script src="http://www.google-analytics.com/urchin.js" type="text/javascript">
+ </script>
+ <script type="text/javascript">
+ _uacct = "UA-89317-1";
+ urchinTracker ();
+ </script>
+ Google Analytics -->
+
+ <?php
+ include "../php/clearscm.php";
+ menu_css ();
+ ?>
+</head>
+
+<body>
+
+<?php heading ();?>
+
+<div id="page">
+ <div id="content">
+ <?php start_box ("cs5");?>
+ <h2>listsynlists</h2>
+ <p>Lists Dynamic Lists present in the database</p>
+ <?php end_box ();?>
+
+ <?php display_code ("cq/listdynlists");?>
+ </div>
+ <?php copyright ();?>
+</div>
+
+<script language="JavaScript" src="/JavaScript/Menus.js" type="text/javascript"></script>
+
+</body>
+</html>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+
+ <title>ClearSCM: Clearquest: pqaclean</title>
+
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Article.css">
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Code.css">
+ <link rel="stylesheet" type="text/css" media="print" href="/css/Print.css">
+ <link rel="SHORTCUT ICON" href="http://clearscm.com/favicon.ico" type="image/png">
+
+ <!-- Google Analytics
+ <script src="http://www.google-analytics.com/urchin.js" type="text/javascript">
+ </script>
+ <script type="text/javascript">
+ _uacct = "UA-89317-1";
+ urchinTracker ();
+ </script>
+ Google Analytics -->
+
+ <?php
+ include "../php/clearscm.php";
+ menu_css ();
+ ?>
+</head>
+
+<body>
+
+<?php heading ();?>
+
+<div id="page">
+ <div id="content">
+ <?php start_box ("cs5");?>
+ <h2>pqaclean</h2>
+ <p>Cleans up by removing all records from the destination
+ database as well as removing all Dynamic Lists.</p>
+ <?php end_box ();?>
+
+ <?php display_code ("cq/pqaclean");?>
+ </div>
+ <?php copyright ();?>
+</div>
+
+<script language="JavaScript" src="/JavaScript/Menus.js" type="text/javascript"></script>
+
+</body>
+</html>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+
+ <title>ClearSCM: Clearquest: pqamerge</title>
+
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Article.css">
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Code.css">
+ <link rel="stylesheet" type="text/css" media="print" href="/css/Print.css">
+ <link rel="SHORTCUT ICON" href="http://clearscm.com/favicon.ico" type="image/png">
+
+ <!-- Google Analytics
+ <script src="http://www.google-analytics.com/urchin.js" type="text/javascript">
+ </script>
+ <script type="text/javascript">
+ _uacct = "UA-89317-1";
+ urchinTracker ();
+ </script>
+ Google Analytics -->
+
+ <?php
+ include "../php/clearscm.php";
+ menu_css ();
+ ?>
+</head>
+
+<body>
+
+<?php heading ();?>
+
+<div id="page">
+ <div id="content">
+ <?php start_box ("cs5");?>
+ <h2>pqamerge</h2>
+ <p>This script performed the merge of the two Clearquest
+ databases</p>
+ <?php end_box ();?>
+
+ <?php display_code ("cq/pqamerge");?>
+ </div>
+ <?php copyright ();?>
+</div>
+
+<script language="JavaScript" src="/JavaScript/Menus.js" type="text/javascript"></script>
+
+</body>
+</html>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+
+ <title>ClearSCM: Contact Information</title>
+
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Article.css">
+ <link rel="stylesheet" type="text/css" media="print" href="/css/Print.css">
+ <link rel="SHORTCUT ICON" href="http://clearscm.com/favicon.ico" type="image/png">
+
+ <!-- Google Analytics
+ <script src="http://www.google-analytics.com/urchin.js" type="text/javascript">
+ </script>
+ <script type="text/javascript">
+ _uacct = "UA-89317-1";
+ urchinTracker ();
+ </script>
+ Google Analytics -->
+
+ <?php
+ include "php/clearscm.php";
+ menu_css ();
+ ?>
+</head>
+
+<body>
+
+<?php heading ();?>
+
+<div id="page">
+ <div id="content">
+ <center>
+
+ <iframe src="businesscard.html" frameborder="0" width="100%" height="260"></iframe>
+ </center>
+ </div> <!-- content -->
+
+ <?php copyright ();?>
+</div>
+
+<script language="JavaScript" src="/JavaScript/Menus.js" type="text/javascript"></script>
+
+</body>
+</html>
--- /dev/null
+/****************************************************************************
+Sets minimal style for unsupported browsers and then imports the css
+files (used by compliant browsers). The following browsers will only
+get the minimal css styling listed below this comment:
+
+ NN 4.x, IE 3, IE 4.
+
+NOTE: imports must use the quoted file name syntax for the import,
+'@import "x.css",' not the '@import url(x.css)' form which IE 4
+recognizes.
+*****************************************************************************/
+@import url(LevelThePlayingField.css);
+@import url(ColoredBoxesRoundedCorners.css);
+@import url(ArticleLayout.css);
+
+h2 {
+ text-align: center;
+}
+
+div.filtered {
+ color: red;
+ border: 2px solid #6600FF;
+ background-color: #E8E8E8;
+ padding: 5px;
+}
+
+.filtered, .filtered a {
+ color: #333399;
+ font-style: italic;
+}
+
+.fontsize-set a#medium {
+ font-size: 120%;
+}
+
+.fontsize-set a#large {
+ font-size: 140%;
+}
--- /dev/null
+/*-----------------------------------------------------------------------
+This css file is part of a layout package. Used on its own it won't
+have the desired effect. The corresponding HTML file should LINK to a
+filter.css file which will then IMPORT this style sheet (effecively
+hiding it from IE3, IE4 and NN4). Imported ahead of this file should
+be one named lpf.css (lpf = Level Playing Field) which attempts to get
+all the different browsers using the same measurements, including font
+sizes.
+
+Not related to the layout but also used in this example is 1 of Stu
+Nicholls' wonderful creations (somewhat customized). This styles the
+color boxes with rounded corners used in the content area. The style
+for this, also imported by filter.css, is cbrc.css and it contains its
+own documentation.
+
+======================================================================
+ Copyright and LICENSE -- do not remove --
+======================================================================
+This CSS file is copyrighted (c) 2005, Paul Pomeroy/AdaptiveView
+
+see: http://design.adaptiveview.com
+
+but free to use under a Creative Commons Attribution 2.5 license.
+Full details about this license are online at:
+
+http://creativecommons.org/licenses/by/2.5/
+----------------------------------------------------------------------- */
+html, body, #page {
+ height:100%;
+ width:100%;
+}
+
+body {
+ background-color: #fff;
+ margin-left:auto;
+ margin-right:auto;
+ text-align:center;
+}
+
+html>body, html>body #page {
+ height:auto;
+}
+
+#head {
+ background: url(/Images/TopOfTheWorld.jpg);
+ color:white;
+ border-top:1px solid #306;
+ border-bottom:1px solid #306;
+ position:absolute;
+ height:165px;
+ left:0;
+ min-width:775px;
+ top:0px;
+ width:100%;
+ width:expression(document.body.clientWidth < 800? "775px": "100%" ); /* min-width IE style*/
+ z-index:10;
+}
+
+#head h1 {
+ color: #fff;
+ font-size: 3em;
+ padding-top: 20px;
+ text-align: center;
+}
+
+#page {
+ left:0;
+ background: white;
+ color: #2a4c96;
+ position:absolute;
+ text-align:center;
+ top:166px;
+ z-index:8;
+}
+
+#content {
+ margin-left:auto;
+ margin-right:auto;
+ max-width:955px;
+ min-width:775px;
+ padding-bottom:4.0em; /* you can get all of the padding set in one line, but Mac IE5.2 has issues with the shorthand method. */
+ padding-left:4px;
+ padding-right:4px;
+ padding-top:10px;
+ width:expression(document.body.clientWidth < 800? "775px" : document.body.clientWidth > 1024? "999px": "99%"); /* IE's version of min- and max-width */
+ z-index:1;
+}
+
+* html #page, * html #content {
+ height:100%;
+}
+
+* html #page {
+ width:auto;
+}
+
+#foot {
+ width:100%;
+ z-index:99;
+}
+
+#foot p {
+ color: #aaa;
+ font-size: 80%;
+ text-align: center;
+}
+
+html>body #foot { /* anyone but IE */ */
+ bottom: 0;
+ left: 0;
+ position: absolute;
+}
+
+* html #foot { /* IE */
+ color: #aaa;
+ margin-left: auto;
+ margin-right: auto;
+ width: auto;
+}
+
+abbr {
+ cursor: help;
+}
+
+#head, #foot {
+ padding-bottom:0;
+ padding-top:0;
+}
+
+#content p, #content h2, #content h3, #content h4, #content h5 {
+ margin:11px 11px;
+}
+
+#main {
+ background:transparent;
+ min-height:100%;
+ z-index:15;
+}
+
+#main {
+ width:90%;
+}
+
+#main p.tagline {
+ color:#939;
+ font-size:1.4em;
+ font-style:italic;
+ text-align:center;
+}
+
+
+.hide, .filtered {display:none;}
+
+.clear {
+ clear:both;
+ margin-bottom: -1px; /* for Gecko-based browsers */
+ overflow:hidden;
+ padding-bottom: 1px; /* for Gecko-based browsers */
+}
+
+.clearfix:after {
+ clear: both;
+ content: ".";
+ display: block;
+ height: 0;
+ visibility: hidden;
+}
+
+.clearfix {display: inline-table;}
+
+/* Hides from IE-mac \*/
+* html .clearfix {height: 1%;}
+.clearfix {display: block;}
+/* End hide from IE-mac */
\ No newline at end of file
--- /dev/null
+.code {
+ border-top: 1px solid #ddd;
+ border-left: 1px solid #ddd;
+ border-right: 2px solid #000;
+ border-bottom: 2px solid #000;
+ padding: 10px;
+ margin-top: 5px;
+ margin-left: 5%;
+ margin-right: 5%;
+ background: #ffffea;
+ color: black;
+ font-family: courier;
+ white-space: pre;
+ -moz-border-radius: 10px;
+ border-radius: 10px;
+}
+
+#code {
+ color: black;
+ font-size: 14px;
+ font-family: courier;
+ border-bottom: 1px dotted #ddd;
+ padding-left: 5px;
+}
+
+#line-number {
+ color: #804000;
+ font-family: Arial;
+ font-size: 14px;
+ padding-right: 5px;
+ border-right: 1px dotted #804000;
+ text-align: right;
+ width: 15px;
+}
--- /dev/null
+/*******************************************************************************
+Color Boxes with Round Corners. This is pretty much straight from Stu
+Nicholls' Snazzy Borders (see
+http://www.stunicholls.myby.co.uk/boxes/snazzy.html). Things look a
+little different only because the code's been reformatted and some
+color schemes have been predefined.
+
+- Paul Pomeroy (July, 2005)
+*******************************************************************************/
+.rcbox h1, .rcbox h2, .rcbox p {margin:-10px; letter-spacing:0.5px; border:0;}
+.rcbox {background: transparent; padding:3px 6px;}
+.rcbox div {padding:4px 4px;}
+
+
+.xboxcontent {display:block; background:#eee; border:0 solid #fff; border-width:0 1px;}
+.xb2, .xb3, .xb4 {border-left:1px solid #fff; border-right:1px solid #fff;}
+.xb1 {margin:0 5px; background:#fff;}
+.xb2 {margin:0 3px; border-width:0 2px;}
+.xb3 {margin:0 2px;}
+.xb4 {height:2px; margin:0 1px;}
+.xb1, .xb2, .xb3, .xb4 {display:block; overflow:hidden;}
+.xb1, .xb2, .xb3 {height:1px;}
+.xtop, .xbottom {display:block; background:transparent; font-size:1px;}
+
+/* ================Default Color Scheme================= */
+.xb2, .xb3, .xb4 {
+ background:#eac; border-left-color:#fff; border-right-color:#fff;} .xb1 {background:#fff;}
+ /* : : : : */
+ /* :..background. :............border......:......border...........: */
+ /* : : */
+.xboxcontent { background:#eac; border-color:#fff;}
+.xboxcontent h2, .xboxcontent h3, .xboxcontent h4, .xboxcontent p {color:#111;}
+
+/* =================Color Scheme 1===================== */
+.cs1 .xb2, .cs1 .xb3, .cs1 .xb4 {
+ background:#906; border-left-color:#fff; border-right-color:#fff;} .cs1 .xb1 {background:#fff;}
+ /* : : : : */
+ /* :..background...... :........border..........:......border................: */
+ /* : : */
+.cs1 .xboxcontent { background:#906; border-color:#fff;}
+.cs1 .xboxcontent h2, .cs1 .xboxcontent h3, .cs1 .xboxcontent h4, .cs1 .xboxcontent p {color:#000;}
+
+/* =================Color Scheme 2===================== */
+.cs2 .xb2, .cs2 .xb3, .cs2 .xb4 {
+ background:#eef; border-left-color:#ddd; border-right-color:#ddd;} .cs2 .xb1 {background:#ddd;}
+ /* : : : : */
+ /* :..background...... :........border..........:......border................: */
+ /* : : */
+.cs2 .xboxcontent { background:#eef; border-color:#ddd;}
+.cs2 .xboxcontent h2, .cs2 .xboxcontent h3, .cs2 .xboxcontent h4, .cs2 .xboxcontent p {color:#222;}
+
+/* ==IMG============Color Scheme 3================IMG== */
+.cs3 .xb2, .cs3 .xb3, .cs3 .xb4 {
+ background:#fff url(/Images/Clouds.jpg); border-left-color:#eef; border-right-color:#eef;} .cs3 .xb1 {background:#eef;}
+ /* : : : : */
+ /* :..background...... :........border..........:......border................: */
+ /* : : */
+.cs3 .xboxcontent { background:#fff url(/Images/Clouds.jpg); border-color:#eef;}
+.cs3 .xboxcontent h2, .cs3 .xboxcontent h3, .cs3 .xboxcontent h4, .cs3 .xboxcontent p {color:#113;}
+
+/* ==IMG============Color Scheme 4================IMG== */
+.cs4 .xb2, .cs4 .xb3, .cs4 .xb4 {
+ background:#fff url(/Images/tbg-bl-mg.jpg); border-left-color:#eef; border-right-color:#eef;} .cs4 .xb1 {background:#eef;}
+ /* : : : : */
+ /* :..background...... :........border..........:......border................: */
+ /* : : */
+.cs4 .xboxcontent { background:#fff url(/Images/tbg-bl-mg.jpg); border-color:#eef;}
+.cs4 .xboxcontent h2, .cs4 .xboxcontent h3, .cs4 .xboxcontent h4, .cs4 .xboxcontent p {color:#113;}
+
+/* ==IMG============Color Scheme 5================IMG== */
+.cs5 .xb2, .cs5 .xb3, .cs5 .xb4 {
+ background:#fff url(/Images/tbg-mg-bl.jpg); border-left-color:#b9f; border-right-color:#b9f;} .cs5 .xb1 {background:#b9f;}
+ /* : : : : */
+ /* :..background...... :........border..........:......border................: */
+ /* : : */
+.cs5 .xboxcontent { background:#fff url(/Images/tbg-mg-bl.jpg); border-color:#b9f;}
+.cs5 .xboxcontent h2, .cs5 .xboxcontent h3, .cs5 .xboxcontent h4, .cs5 .xboxcontent p {color:#111;}
+
+/* =================Color Scheme 6===================== */
+.cs6 .xb2, .cs6 .xb3, .cs6 .xb4 {
+ background:#fff; border-left-color:#aac; border-right-color:#aac;} .cs6 .xb1 {background:#aac;}
+ /* : : : : */
+ /* :..background...... :........border..........:......border................: */
+ /* : : */
+.cs6 .xboxcontent { background:#fff; border-color:#aac;}
+.cs6 .xboxcontent h2, .cs6 .xboxcontent h3, .cs6 .xboxcontent h4, .cs6 .xboxcontent p {color:#222;}
\ No newline at end of file
--- /dev/null
+/****************************************************************************
+Sets minimal style for unsupported browsers and then imports the css
+files (used by compliant browsers). The following browsers will only
+get the minimal css styling listed below this comment:
+
+ NN 4.x, IE 3, IE 4.
+
+NOTE: imports must use the quoted file name syntax for the import,
+'@import "x.css",' not the '@import url(x.css)' form which IE 4
+recognizes.
+*****************************************************************************/
+@import url(LevelThePlayingField.css);
+@import url(ColoredBoxesRoundedCorners.css);
+@import url(Main.css);
+
+div.filtered {
+ color: red;
+ border: 2px solid #6600FF;
+ background-color: #E8E8E8;
+ padding: 5px;
+}
+
+.filtered, .filtered a {
+ color: #333399;
+ font-style: italic;
+}
+
+.fontsize-set a#medium {
+ font-size: 120%;
+}
+
+.fontsize-set a#large {
+ font-size: 140%;
+}
\ No newline at end of file
--- /dev/null
+/*****************************************************************************
+lpf.css -- Level the Playing Field. Majorly modified form of
+"undohtml.css" (C) 2004 by Tantek Celik. Some Rights Reserved. His
+style sheet is licensed under a Creative Commons License.
+
+See http://creativecommons.org/licenses/by/2.0
+
+Modifications made by Paul Pomeroy, July 2005.
+
+Whatever isn't Tantek's, consider it free for the taking but as I have
+no idea what your requirments may be and no control over how you use
+the following, all risks are assumed by you. Okay?
+
+Purpose: undo some of the default styling of common (X)HTML browsers
+so all browers can start from the same settings (or as close as
+possible)
+*****************************************************************************/
+* {
+ /* IE5/Mac likes this, doesn't like ...:relative;. */
+ /* hide from IE5/Mac */
+ position: static;
+ /* rumored to help with some IE problems (other than IE5/Mac. */
+ position: relative;
+ /* IE sometimes decides to center stuff for the heck of it */
+ text-align: left;
+ font-size: 1em;
+}
+
+body {
+ margin: 0;
+ padding: 0;
+}
+
+/*ul,
+ol,*/
+
+li,
+h1,
+h2,
+h3,
+h4,
+h5,
+h6,
+pre,
+form,
+body,
+html,
+p,
+blockquote,
+fieldset,
+input {
+ margin: 0;
+}
+
+dt {
+ padding-left: 12px;
+}
+
+blockquote {
+ padding-left: 25px;
+}
+
+/*****************************************************************************
+No list-markers by default, since lists are used more often for semantics
+*****************************************************************************/
+/* ul,ol { list-style:none; }*/
+
+/*****************************************************************************
+Link underlines tend to make hypertext less readable, because
+underlines obscure the shapes of the lower halves of words
+*****************************************************************************/
+:link,:visited {
+ text-decoration: none;
+}
+
+/*****************************************************************************
+Try getting rid of blue linked borders.
+*****************************************************************************/
+#page a {
+ border: none;
+ font-weight: bold;
+}
+
+#page a:link {
+ color: red;
+}
+
+#page a:visited {
+ color: teal;
+}
+
+#page a:active {
+ color: red;
+}
+
+#page a:hover {
+ color: blue;
+ background: #ffff80;
+}
+
+a img,
+:link img,
+:visited img {
+ border: none;
+}
+
+/*****************************************************************************
+Now set up the default fonts and font sizes...
+
+We'll start with a size of 12px (1em = 12px)
+*****************************************************************************/
+
+body {
+ font-family: verdana, arial, sans-serif;
+ font-size: 75%; /* assumes a 14-16px default size */
+ line-height: 137%;
+}
+
+/*****************************************************************************
+Let IE use percentage for base font size so it can still zoom
+text. Everyone else we'll give a pixel value to ...
+*****************************************************************************/
+html>body {
+ font-size: 12px; /* For everyone except IE ... */
+}
+
+p {
+ font-size: 1.0em; /* ~12px */
+}
+
+h1, h2, h3, h4, h5, h6 { /* georgia is a better x-browser font */
+ font-family: georgia, "new century schoolbook", times, serif;
+ margin-top: 4px;
+ margin-bottom: 10px;
+ color: #993333;
+}
+
+h1 {
+ font-weight: normal;
+}
+h2, h3, h4, h5, h6 {
+ font-weight: bolder;
+}
+
+
+h1 {
+ font-size: 2em;
+ font-variant: small-caps;
+ text-align: center;
+}
+
+h2 {
+ font-size: 1.5em;
+ font-variant: small-caps;
+ font-weight: bolder;
+}
+
+h3 {
+ font-size: 1em;
+ font-weight: bolder;
+}
+
+h4 {
+ font-size: 0.8em;
+ font-style: italic;
+}
+
+h5 {
+ font-size: 0.6em;
+ font-style: italic;
+}
+
+h6 {
+ font-size: 0.4em;
+ font-weight: bold;
+}
+
+.standout {
+ font-family: verdana,
+ arial,
+ sans-serif;
+ font-size: 12px;
+ color: #933;
+ line-height: 13px;
+ font-weight: bold;
+ margin-bottom: 10px;
+}
+
+.dim {
+ color: #999;
+}
--- /dev/null
+/*-----------------------------------------------------------------------
+This CSS file is for implementing a 3-column layout based on the
+"opposite floats" concept. I've seen this concept explained a few
+times but never as clearly as in the article "3 Column Layouts - A
+Different Approach" -- (C) 2005, Sebastian Schmieg. The article can be
+found at: http://www.kingcosmonaut.de/journal/3col-layout/ and is
+worth your time to go have a read first before diving into the
+followng css.
+
+This css file is part of a layout package. Used on its own it won't
+have the desired effect. The corresponding HTML file should LINK to a
+filter.css file which will then IMPORT this style sheet (effecively
+hiding it from IE3, IE4 and NN4). Imported ahead of this file should
+be one named lpf.css (lpf = Level Playing Field) which attempts to get
+all the different browsers using the same measurements, including font
+sizes.
+
+Not related to the layout but also used in this example is 1 of Stu
+Nicholls' wonderful creations (somewhat customized). This styles the
+color boxes with rounded corners used in the content area. The style
+for this, also imported by filter.css, is cbrc.css and it contains its
+own documentation.
+
+======================================================================
+ Copyright and LICENSE -- do not remove --
+======================================================================
+This CSS file is copyrighted (c) 2005, Paul Pomeroy/AdaptiveView
+
+see: http://design.adaptiveview.com
+
+but free to use under a Creative Commons Attribution 2.5 license.
+Full details about this license are online at:
+
+http://creativecommons.org/licenses/by/2.5/
+----------------------------------------------------------------------- */
+html, body, #page {
+ height: 100%;
+ width: 100%;
+}
+
+body {
+ background-color: #fff;
+ margin-left: auto;
+ margin-right: auto;
+ text-align: center;
+}
+
+html>body, html>body #page {
+ height: auto;
+}
+
+#head {
+ background: url(/Images/TopOfTheWorld.jpg);
+ color: white;
+ border-top: 1px solid #306;
+ border-bottom: 1px solid #306;
+ position: absolute;
+ height: 165px;
+ left: 0;
+/* max-width: 955px;*/
+ min-width: 775px;
+ top: 0px;
+ width: 100%;
+ width: expression(document.body.clientWidth < 800? "775px": "100%" ); /* min-width IE style*/
+ z-index: 10;
+}
+
+#head h1 {
+ color: #fff;
+ font-size: 3em;
+ padding-top: 20px;
+ text-align: center;
+}
+
+#page {
+ left: 0;
+ background: #2a4c96 url(/Images/Background.jpg);
+ color: #000;
+ position: absolute;
+ text-align: center;
+ top: 166px;
+ z-index: 8;
+ min-height: 858px;
+}
+
+#content {
+ margin-left: auto;
+ margin-right: auto;
+ max-width: 955px;
+ min-width: 775px;
+ padding-bottom: 4.0em; /* you can get all of the padding set in one line, but Mac IE5.2 has issues with the shorthand method. */
+ padding-left: 4px;
+ padding-right: 4px;
+ padding-top: 10px;
+ width: expression(document.body.clientWidth < 800? "775px" : document.body.clientWidth > 1024? "999px": "99%"); /* IE's version of min- and max-width */
+ z-index: 1;
+}
+
+* html #page, * html #content {
+ height: 100%;
+}
+
+* html #page {
+ width: auto;
+}
+
+#foot {
+ background: transparent;
+ width: 100%;
+ z-index: 99;
+ text-align: center;
+}
+
+#foot p {
+ color: #aaa;
+ font-size: 80%;
+ text-align: center;
+}
+
+html>body #foot { /* anyone but IE */
+ bottom: 0;
+ left: 0;
+ position: absolute;
+}
+
+* html #foot { /* IE */
+ color: #eee;
+ margin-left: auto;
+ margin-right: auto;
+ width: auto;
+}
+
+abbr {
+ cursor: help;
+}
+
+#head, #foot {
+ padding-bottom: 0;
+ padding-top: 0;
+}
+
+#content p,
+#content h2,
+#content h3,
+#content h4,
+#content h5 {
+ margin: 11px 11px;
+}
+
+#supporting, #related {
+ font-size: 90%;
+}
+
+* html #supporting, * html #related {
+ overflow:hidden; /* keeps columns from getting pushed down when large font sizes cause words to exceed column width in IE6 */
+}
+
+/*
+ The quick explanation for this layout scheme:
+
+ You have 3 columns for your content. I call them "main," "supporting" and
+ "related." There are two containers (divs) in which to put these 3 columns,
+ so one container will get 2 columns and the other will get 1. The containers
+ are named "contentWrapper1" and "contentWrapper2." Both of these containers
+ are in a container of their own, called "content." In XHTML, the heirarchy
+ looks like:
+
+ <div id="content">
+
+ <div id="contentWrapper1">
+ <div id="main"> ... your main content ... </div>
+ </div> <!-- end of contentWrapper1 -->
+
+ <div id="contentWrapper2">
+ <div id="supporting">
+ ... content supporting main ...
+ </div>
+ <div id="related">
+ ... content related to main ...
+ </div>
+ </div> <!-- end of contentWrapper2 -->
+
+ </div> <!-- end of content -->
+
+ NOTE: In the XHTML it doesn't matter which wrapper div is first. Within
+ the wrapper that's containing two content columns (contentWrapper2)
+ it doesn't matter which content comes first. It's fairly easy,
+ therefore, to put your content in any order you want.
+
+ The content div is alloted 100% width. The two content wrapper divs sit
+ side by side, one floated left, the other floated right. Their combined
+ width must be UNDER 100% (if they're >= 100% then the second wrapper is
+ going to slip down under the first).
+
+ Within one of the wrappers, it doesn't matter which, you'll have two
+ content divs (again, it doesn't matter which) and one will be floated left
+ and the other right. Their combined widths must also be < 100%.
+
+ Without touching the XHTML, you can get FOUR arrangements of the three
+ columns by swapping the left and right floats (==> and <== indicate swaps):
+
+ 1. Wrapper 1 Wrapper 2
+ Main Supporting Related
+
+ 2. Wrapper 1 Wrapper 2
+ Main ==> Related Supporting <==
+
+ 3. ==> Wrapper 2 Wrapper 1 <==
+ Related Supporting Main
+
+ 4. Wrapper 2 Wrapper 1
+ ==> Supporting Related <== Main
+
+ by changing the XHTML so the main content is paired up with one of the
+ others (doesn't matter which) you can get TWO additional layouts in
+ which the main content is flanked by the other two columns:
+
+ 5. Wrapper 1 Wrapper 2
+ Supporting Main Related
+
+ 6. ==> Wrapper 2 Wrapper 1 <==
+ Related ==> Main Supporting <==
+
+ ******************************
+ ********* HOWEVER **********
+ ******************************
+ I've set this css up to change column arrangements via the class assigned to
+ the body tag. See the HTML file for more information, and below for the css
+ styles used to accomplish this...
+
+ */
+
+#contentWrapper1,
+#contentWrapper2,
+#main,
+#related,
+#supporting {
+ background:transparent;
+ min-height:100%;
+ z-index:15;
+}
+
+#contentWrapper1 {
+ width:25%;
+}
+
+#contentWrapper2 {
+ width:74.0%;
+}
+
+#main {
+ width:66.0%;
+}
+
+#main p.tagline {
+ color:#939;
+ font-size:1.4em;
+ font-style:italic;
+ text-align:center;
+}
+
+#supporting {
+ width:33%;
+}
+
+#related {
+ width:33%;
+}
+
+body.m-sr #contentWrapper1,
+body.m-rs #contentWrapper1,
+body.sr-m #contentWrapper1,
+body.rs-m #contentWrapper1 {
+ width:49.5%;
+}
+
+body.m-sr #contentWrapper2,
+body.m-rs #contentWrapper2,
+body.sr-m #contentWrapper2,
+body.rs-m #contentWrapper2 {
+ width:49.5%;
+}
+
+body.m-sr #main,
+body.m-rs #main,
+body.sr-m #main,
+body.rs-m #main {
+ width:99.5%;
+}
+
+body.m-sr #supporting, body.m-sr #related,
+body.m-rs #supporting, body.m-rs #related,
+body.sr-m #supporting, body.sr-m #related,
+body.rs-m #supporting, body.rs-m #related {
+ width:49.5%;
+}
+
+body.r-sm #related,
+body.r-ms #related,
+body.sm-r #related,
+body.ms-r #related {
+ width:99.0%;
+}
+
+body.s-rm #supporting,
+body.s-mr #supporting,
+body.rm-s #supporting,
+body.mr-s #supporting {
+ width:99.0%;
+}
+
+body.m-sr #contentWrapper1,
+body.m-rs #contentWrapper1,
+body.s-mr #contentWrapper1,
+body.s-rm #contentWrapper1,
+body.r-ms #contentWrapper1,
+body.r-sm #contentWrapper1 {
+ float:left;
+}
+
+body.sr-m #contentWrapper1,
+body.rs-m #contentWrapper1,
+body.mr-s #contentWrapper1,
+body.rm-s #contentWrapper1,
+body.ms-r #contentWrapper1,
+body.sm-r #contentWrapper1 {
+ float:right;
+}
+
+body.m-sr #contentWrapper2,
+body.m-rs #contentWrapper2,
+body.s-mr #contentWrapper2,
+body.s-rm #contentWrapper2,
+body.r-ms #contentWrapper2,
+body.r-sm #contentWrapper2 {
+ float:right;
+}
+
+body.sr-m #contentWrapper2,
+body.rs-m #contentWrapper2,
+body.mr-s #contentWrapper2,
+body.rm-s #contentWrapper2,
+body.ms-r #contentWrapper2,
+body.sm-r #contentWrapper2 {
+ float:left;
+}
+
+body.s-mr #main,
+body.r-ms #main,
+body.mr-s #main,
+body.ms-r #main {
+ float:left;
+}
+
+body.s-rm #main,
+body.r-sm #main,
+body.rm-s #main,
+body.sm-r #main {
+ float:right;
+}
+
+body.m-sr #related,
+body.s-mr #related,
+body.sr-m #related,
+body.mr-s #related {
+ float:right;
+}
+
+body.m-rs #related,
+body.s-rm #related,
+body.rs-m #related,
+body.rm-s #related {
+ float:left;
+}
+
+body.m-sr #supporting,
+body.r-sm #supporting,
+body.sr-m #supporting,
+body.sm-r #supporting {
+ float:left;
+}
+
+body.m-rs #supporting,
+body.r-ms #supporting,
+body.rs-m #supporting,
+body.ms-r #supporting {
+ float:right;
+}
+
+.hide, .filtered {display:none;}
+
+.clear {
+ clear:both;
+ margin-bottom: -1px; /* for Gecko-based browsers */
+ overflow:hidden;
+ padding-bottom: 1px; /* for Gecko-based browsers */
+}
+
+.clearfix:after {
+ clear: both;
+ content: ".";
+ display: block;
+ height: 0;
+ visibility: hidden;
+}
+
+.clearfix {display: inline-table;}
+
+/* Hides from IE-mac \*/
+* html .clearfix {height: 1%;}
+.clearfix {display: block;}
+/* End hide from IE-mac */
+
--- /dev/null
+/*****************************************************************************
+Sets minimal style for unsupported browsers and then imports the css
+files (used by compliant browsers). The following browsers will only
+get the minimal css styling listed below this comment:
+
+ NN 4.x, IE 3, IE 4.
+
+NOTE: imports must use the quoted file name syntax for the import,
+'@import "x.css",' not the '@import url(x.css)' form which IE 4
+recognizes.
+*****************************************************************************/
+@import url(LevelThePlayingField.css);
+@import url(ColoredBoxesRoundedCorners.css);
+@import url(ManPageLayout.css);
+
+div.filtered {
+ color: red;
+ border: 2px solid #6600FF;
+ background-color: #E8E8E8;
+ padding: 5px;
+}
+
+.filtered, .filtered a {
+ color: #333399;
+ font-style: italic;
+}
+
+.fontsize-set a#medium {
+ font-size: 120%;
+}
+
+.fontsize-set a#large {
+ font-size: 140%;
+}
--- /dev/null
+/*-----------------------------------------------------------------------
+This css file is part of a layout package. Used on its own it won't
+have the desired effect. The corresponding HTML file should LINK to a
+filter.css file which will then IMPORT this style sheet (effecively
+hiding it from IE3, IE4 and NN4). Imported ahead of this file should
+be one named lpf.css (lpf = Level Playing Field) which attempts to get
+all the different browsers using the same measurements, including font
+sizes.
+
+Not related to the layout but also used in this example is 1 of Stu
+Nicholls' wonderful creations (somewhat customized). This styles the
+color boxes with rounded corners used in the content area. The style
+for this, also imported by filter.css, is cbrc.css and it contains its
+own documentation.
+
+======================================================================
+ Copyright and LICENSE -- do not remove --
+======================================================================
+This CSS file is copyrighted (c) 2005, Paul Pomeroy/AdaptiveView
+
+see: http://design.adaptiveview.com
+
+but free to use under a Creative Commons Attribution 2.5 license.
+Full details about this license are online at:
+
+http://creativecommons.org/licenses/by/2.5/
+----------------------------------------------------------------------- */
+html, body, #page {
+ height:100%;
+ width:100%;
+}
+
+body {
+ background-color: #fff;
+ margin-left:auto;
+ margin-right:auto;
+ text-align:center;
+}
+
+html>body, html>body #page {
+ height:auto;
+}
+
+#head {
+ background: url(/Images/TopOfTheWorld.jpg);
+ color:white;
+ border-top:1px solid #306;
+ border-bottom:1px solid #306;
+ position:absolute;
+ height:165px;
+ left:0;
+ min-width:775px;
+ top:0px;
+ width:100%;
+ width:expression(document.body.clientWidth < 800? "775px": "100%" ); /* min-width IE style*/
+ z-index:10;
+}
+
+#head h1 {
+ color: #933;
+ font-size: 1.75em;
+ padding-top: 10px;
+ text-align: left;
+}
+
+#page {
+ left:0;
+ background: white;
+ color: #2a4c96;
+ position:absolute;
+ text-align:center;
+ top:166px;
+ z-index:8;
+}
+
+#content {
+ margin-left:auto;
+ margin-right:auto;
+ max-width:955px;
+ min-width:775px;
+ padding-bottom:4.0em; /* you can get all of the padding set in one line, but Mac IE5.2 has issues with the shorthand method. */
+ padding-left:4px;
+ padding-right:4px;
+ padding-top:10px;
+ width:expression(document.body.clientWidth < 800? "775px" : document.body.clientWidth > 1024? "999px": "99%"); /* IE's version of min- and max-width */
+ z-index:1;
+}
+
+* html #page, * html #content {
+ height:100%;
+}
+
+* html #page {
+ width:auto;
+}
+
+#foot {
+ width:100%;
+ z-index:99;
+}
+
+#foot p {
+ color: #aaa;
+ font-size: 80%;
+ text-align: center;
+}
+
+html>body #foot { /* anyone but IE */ */
+ bottom: 0;
+ left: 0;
+ position: absolute;
+}
+
+* html #foot { /* IE */
+ color: #aaa;
+ margin-left: auto;
+ margin-right: auto;
+ width: auto;
+}
+
+abbr {
+ cursor: help;
+}
+
+#head, #foot {
+ padding-bottom:0;
+ padding-top:0;
+}
+
+#content p, #content h2, #content h3, #content h4, #content h5 {
+ margin:11px 11px;
+}
+
+#main {
+ background:transparent;
+ min-height:100%;
+ z-index:15;
+}
+
+#main {
+ width:90%;
+}
+
+#main p.tagline {
+ color:#939;
+ font-size:1.4em;
+ font-style:italic;
+ text-align:center;
+}
+
+
+.hide, .filtered {display:none;}
+
+.clear {
+ clear:both;
+ margin-bottom: -1px; /* for Gecko-based browsers */
+ overflow:hidden;
+ padding-bottom: 1px; /* for Gecko-based browsers */
+}
+
+.clearfix:after {
+ clear: both;
+ content: ".";
+ display: block;
+ height: 0;
+ visibility: hidden;
+}
+
+.clearfix {display: inline-table;}
+
+/* Hides from IE-mac \*/
+* html .clearfix {height: 1%;}
+.clearfix {display: block;}
+/* End hide from IE-mac */
--- /dev/null
+.imcm ul,\r
+.imcm li,\r
+.imcm div,\r
+.imcm span,\r
+.imcm a {\r
+ text-align: left;\r
+ vertical-align: top;\r
+ padding: 0px;\r
+ margin: 0;\r
+ list-style: none outside none;\r
+ border-style: none;\r
+ background-image: none;\r
+ clear: none;\r
+ float: none;\r
+ display: block;\r
+ position: static;\r
+ overflow: visible;\r
+ line-height: normal;\r
+}\r
+\r
+.imcm li a img {\r
+ display: inline;\r
+ border-width: 0px;\r
+}\r
+\r
+.imcm span {\r
+ display: inline;\r
+}\r
+\r
+.imcm .imclear,\r
+.imclear {\r
+ clear: both;\r
+ height: 0px;\r
+ visibility: hidden;\r
+ line-height: 0px;\r
+ font-size: 1px;\r
+}\r
+\r
+.imcm .imsc {\r
+ position: relative;\r
+}\r
+\r
+.imcm .imsubc {\r
+ position: absolute;\r
+ visibility: hidden;\r
+}\r
+\r
+.imcm li {\r
+ list-style: none;\r
+ font-size: 1px;\r
+ float: left;\r
+}\r
+\r
+.imcm ul ul li {\r
+ width: 100%;\r
+ float: none !important;\r
+}\r
+\r
+.imcm a {\r
+ display: block;\r
+ position: relative;\r
+}\r
+\r
+.imcm ul .imsc,\r
+.imcm ul .imsubc {\r
+ z-index: 10;\r
+}\r
+\r
+.imcm ul ul .imsc,\r
+.imcm ul ul .imsubc {\r
+ z-index: 20;\r
+}\r
+\r
+.imcm ul ul ul .imsc,\r
+.imcm ul ul ul .imsubc {\r
+ z-index: 30;\r
+}\r
+\r
+.imde ul li:hover .imsubc {\r
+ visibility: visible;\r
+}\r
+\r
+.imde ul ul li:hover .imsubc {\r
+ visibility: visible;\r
+}\r
+\r
+.imde ul ul ul li:hover .imsubc {\r
+ visibility: visible;\r
+}\r
+\r
+.imde li:hover ul .imsubc {\r
+ visibility: hidden;\r
+}\r
+\r
+.imde li:hover ul ul .imsubc {\r
+ visibility: hidden;\r
+}\r
+\r
+.imde li:hover ul ul ul .imsubc {\r
+ visibility: hidden;\r
+}\r
+\r
+.imcm .imea {\r
+ display: block;\r
+ position: relative;\r
+ left: 0px;\r
+ font-size: 1px;\r
+ line-height: 1px;\r
+ height: 0px;\r
+ width: 1px;\r
+ float: right;\r
+}\r
+\r
+.imcm .imea span {\r
+ display: block;\r
+ position: relative;\r
+ font-size: 1px;\r
+ line-height: 0px;\r
+}\r
+\r
+.dvs,.dvm {\r
+ border-width: 0px\r
+}\r
+\r
+#imenus0 .imeam span,\r
+#imenus0 .imeamj span {\r
+ background-image: url(/Icons/orange_arrow_down.gif);\r
+ background-repeat: no-repeat;\r
+ background-position: top left;\r
+ width: 16px;\r
+ height: 9px;\r
+ left: -16px;\r
+ top: 3px;\r
+}\r
+\r
+#imenus0 li:hover .imeam span,\r
+#imenus0 li a.iactive .imeamj span {\r
+ background-image: url(/Icons/orange_arrow_down.gif);\r
+ background-repeat: no-repeat;\r
+ background-position: top left;\r
+}\r
+\r
+#imenus0 ul .imeas span,\r
+#imenus0 ul .imeasj span {\r
+ background-image: url(/Icons/orange_arrow_right.gif);\r
+ background-repeat: no-repeat;\r
+ background-position: top left;\r
+ width: 10px;\r
+ height: 13px;\r
+ left: -10px;\r
+ top: 0px;\r
+}\r
+\r
+#imenus0 ul li:hover .imeas span,\r
+#imenus0 ul li a.iactive .imeasj span {\r
+ background-image: url(/Icons/orange_arrow_right.gif);\r
+ background-repeat: no-repeat;\r
+ background-position: top left;\r
+}\r
+\r
+#imouter0 {\r
+ background-image: url(/Images/orange_gradient.gif);\r
+ border-style: solid;\r
+ border-color: #111111;\r
+ border-width: 1px;\r
+ padding: 0px;\r
+}\r
+\r
+#imenus0 li ul {\r
+ background-color: #fef5d8;\r
+ border-style: solid;\r
+ border-color: #111111;\r
+ border-width: 1px;\r
+ padding: 5px;\r
+}\r
+\r
+#imenus0 li a,\r
+#imenus0 .imctitle {\r
+ color: #333333;\r
+ text-align: center;\r
+ font-family: Arial;\r
+ font-size: 12px;\r
+ font-weight: bold;\r
+ text-decoration: none;\r
+ border-style: none;\r
+ border-color: #000000;\r
+ border-width: 0px;\r
+ padding: 2px 5px;\r
+}\r
+\r
+#imenus0 li:hover>a {\r
+ color: #ff0000;\r
+}\r
+\r
+#imenus0 li a.ihover,\r
+.imde imenus0 a:hover {\r
+ color: #ff0000;\r
+}\r
+\r
+#imenus0 li a.iactive {\r
+ text-decoration: underline;\r
+}\r
+\r
+#imenus0 ul a,\r
+#imenus0 .imsubc li .imctitle {\r
+ color: #111111;\r
+ text-align: left;\r
+ font-size: 11px;\r
+ font-weight: normal;\r
+ text-decoration: none;\r
+ border-style: none;\r
+ border-color: #000000;\r
+ border-width: 1px;\r
+ padding: 2px 5px;\r
+}\r
+\r
+#imenus0 ul li:hover>a {\r
+ color: #ff0000;\r
+}\r
+\r
+#imenus0 ul li a.ihover {\r
+ color: #ff0000;\r
+}\r
+\r
+#imenus0 ul li a.iactive {\r
+ text-decoration: underline;\r
+}\r
+\r
--- /dev/null
+/************************************************************************/
+/* File: Plain.css */
+/* Description: Cascading Style Sheet definitions for site */
+/* Author: Andrew@DeFaria.com */
+/* Created: Mon Nov 3 21:55:05 PST 2003 */
+/* Language: Cascading Style Sheet */
+/* */
+/* (c) Copyright 2003, Andrew@DeFaria.com, all rights reserved. */
+/************************************************************************/
+body {
+ background: white;
+ margin: 3px;
+ padding: 2px;
+ font-family: trebuchet MS,
+ trebuchet,
+ verdana,
+ sans-serif,
+ arial;
+ color: black;
+}
+
+.heading {
+ margin-top: 5px;
+ padding: 5px;
+}
+
+h1, h2, h3, h4, h5 {
+ color: #005A9C;
+}
+
+h1.centered {
+ text-align: center;
+}
+
+h1 {
+ font-size: 1.5em;
+}
+
+h2 {
+ font-size: 1.25em;
+}
+
+h3 {
+ font-size: 1em;
+}
+
+h4 {
+ font-size: .75em;
+}
+
+h5 {
+ font-size: .5em;
+}
+
+a {
+ color: #4A7184;
+ text-decoration: none;
+ font-weight: bold;
+ font-family: trebuchet MS,
+ trebuchet,
+ verdana,
+ arial,
+ sans-serif;
+ font-size: 14px;
+ font-weight: bold;
+}
+
+a:link {
+ color: #0080c0;
+}
+
+a:visited {
+ color: #4A7184;
+}
+
+a:active {
+ color: #999966;
+}
+
+a:hover {
+ color: blue;
+ background: #ffff80;
+}
+
+/* For img's that happen to be links, don't put that silly */
+/* border! */
+img {
+ border: none;
+}
+
+font {
+ font-family: trebuchet MS,
+ trebuchet,
+ verdana,
+ arial,
+ sans-serif;
+ font-weight: normal;
+ text-transform: none;
+}
+
+font.title {
+ font-family: trebuchet MS,
+ trebuchet,
+ verdana,
+ arial,
+ sans-serif;
+ font-size: 11px;
+ color: #666;
+ line-height: 15px;
+}
+
+font.title-list {
+ font-family: trebuchet MS,
+ trebuchet,
+ verdana,
+ arial,
+ sans-serif;
+ font-size: 11px;
+ color: #666;
+ line-height: 15px;
+}
+
+font.bold-label {
+ font-family: trebuchet MS,
+ trebuchet,
+ verdana,
+ arial,
+ sans-serif;
+ font-size: 11px;
+ color: #666;
+ font-weight: bold;
+}
+
+font.title-no-padding {
+ font-family: trebuchet MS,
+ trebuchet,
+ verdana,
+ arial,
+ sans-serif;
+ font-size: 11px;
+ color: #FFF;
+}
+
+font.title-padding {
+ font-family: trebuchet MS,
+ trebuchet,
+ verdana,
+ arial,
+ sans-serif;
+ font-size: 11px;
+ color: #FFF;
+ line-height: 15px;
+ padding: 5px;
+}
+
+font.title-padding-grey {
+ font-family: trebuchet MS,
+ trebuchet,
+ verdana,
+ arial,
+ sans-serif;
+ font-size: 11px;
+ color: #333;
+ line-height: 15px;
+ padding: 5px;
+}
+
+font.pagetitle {
+ font-family: trebuchet MS,
+ trebuchet,
+ verdana,
+ arial,
+ sans-serif;
+ font-size: 12px;
+ color: #666;
+ line-height: 15px;
+ font-weight: bold;
+}
+
+font.pagetitlelink {
+ font-family: trebuchet MS,
+ trebuchet,
+ verdana,
+ arial,
+ sans-serif;
+ font-size: 12px;
+ color: #336699;
+ line-height: 15px;
+ font-weight: bold;
+}
+
+font.plain {
+ font-family: trebuchet MS,
+ trebuchet,
+ verdana,
+ arial,
+ sans-serif;
+ font-size: 11px;
+ color: #666;
+ line-height: 15px;
+}
+
+font.instructional {
+ font-family: verdana,
+ arial,
+ sans-serif;
+ font-size: 10px;
+ color: #666;
+ line-height: 13px;
+ text-align: justify;
+}
+
+.message {
+ font-family: verdana,
+ arial,
+ sans-serif;
+ font-size: 11px;
+ color: #669966;
+ line-height: 13px;
+ font-weight: bold;
+ margin-bottom: 10px;
+}
+
+.message a {
+ font-family: verdana,
+ arial,
+ sans-serif;
+ font-size: 11px;
+}
+
+.standout {
+ font-family: verdana,
+ arial,
+ sans-serif;
+ font-size: 12px;
+ color: #993333;
+ line-height: 13px;
+ font-weight: bold;
+ margin-bottom: 10px;
+}
+
+.error-message {
+ font-family: verdana,
+ arial,
+ sans-serif;
+ font-size: 11px;
+ color: #993333;
+ line-height: 13px;
+ font-weight: bold;
+ margin-bottom: 10px;
+}
+
+.error-message a {
+ font-family: verdana,
+ arial,
+ sans-serif;
+ font-size: 21px;
+}
+
+font.instructional-just {
+ font-family: verdana,
+ arial,
+ sans-serif;
+ font-size: 10px;
+ color: #666;
+ line-height: 13px;
+}
+
+font.head1 {
+ font-family: trebuchet MS,
+ trebuchet,
+ verdana,
+ arial,
+ sans-serif;
+ font-size: 11px;
+ color: #336699;
+ line-height: 15px;
+ font-weight: bold;
+}
+
+font.command {
+ font-family: trebuchet MS,
+ trebuchet,
+ verdana,
+ arial,
+ sans-serif;
+ font-size: 12px;
+ line-height: 15px;
+ text-transform: uppercase;
+ font-weight: bold;
+}
+
+font.command-grey {
+ font-family: trebuchet MS,
+ trebuchet,
+ verdana,
+ arial,
+ sans-serif;
+ font-size: 12px;
+ line-height: 15px;
+ color: #666;
+ font-weight: bold;
+}
+
+p {
+ color: black;
+ font-family: Times New Roman,
+ Arial;
+ font-size: 12pt;
+ line-height: 12pt;
+}
+
+ul {
+ color: black;
+ font-family: trebuchet MS,
+ trebuchet,
+ verdana,
+ helvetica,
+ sans-serif;
+ font-size: 14px;
+ line-height: 16px;
+}
+
+li {
+ font-family: trebuchet MS,
+ trebuchet,
+ verdana,
+ helvetica,
+ sans-serif;
+ font-size: 14px;
+ line-height: 16px;
+}
+
+.box {
+ padding: 5px;
+ background-color: #ffffea;
+ color: rgb(165, 42, 42);
+ font-size: 8pt;
+ margin-bottom: 5px;
+ margin-left: auto;
+ margin-right: auto;
+ border-top: 4px solid #804000;
+ border-left: 1px solid #804000;
+ border-bottom: 1px solid #aca899;
+ border-right: 1px solid #aca899;
+ width: 75%;
+ text-align: center;
+ -moz-border-radius: 7px;
+}
+
+.padded-box {
+ border: 1px solid #696;
+ padding: 5px;
+ margin-top: 50px;
+ text-align: center;
+ background: #ccc;
+}
+
+.copyright {
+ border-bottom: 1px dotted #ccc;
+ border-top: 1px dotted #ccc;
+ color: #999;
+ font-family: verdana,
+ arial,
+ sans-serif;
+ font-size: 10px;
+ margin-top: 5px;
+ text-align: center;
+ width: auto;
+}
+
+.copyright a {
+ font-size: 10px;
+}
+
+.input {
+ font-family: verdana,
+ arial,
+ sans-serif;
+ font-size: 11px;
+ font-weight: bold;
+ color: #666;
+}
+
+/* Code */
+.code {
+ border: 2px solid #336699;
+ padding: 5px;
+ margin-top: 20px;
+ background: #ffffea;
+ color: black;
+ font-size: 14px;
+ font-family: courier;
+ -moz-border-radius: 10px;
+}
+
+#code {
+ color: black;
+ font-size: 14px;
+ font-family: courier;
+ padding-left: 5px;
+}
+
+#line-number {
+ color: #804000;
+ font-family: Arial;
+ font-size: 14px;
+ padding-right: 5px;
+ border-right: 1px dotted #804000;
+}
+
+.highlightbox {
+ border: solid;
+ border-top-color: #336699;
+ border-top-width: 4pt;
+ border-left-color: #336699;
+ border-left-width: 1pt;
+ border-bottom-color: #000000;
+ border-bottom-width: 1pt;
+ border-right-color: #000000;
+ border-right-width: 1pt;
+ background-color: #eeeeee;
+ font-size: 8pt;
+ padding: 5px;
+ float: right;
+ text-align: center;
+ width: 200px;
+ -moz-border-radius: 7px;
+}
+
+.centered {
+ text-align: center;
+ margin-left: auto;
+ margin-right: auto;
+}
+
+.floatright {
+ float: right;
+}
+
+.floatcenter {
+ text-align: center;
+}
+
+pre {
+ white-space: pre-wrap; /* css-3 */
+ white-space: -moz-pre-wrap; /* Mozilla, since 1999 */
+ white-space: -pre-wrap; /* Opera 4-6 */
+ white-space: -o-pre-wrap; /* Opera 7 */
+ word-wrap: break-word; /* Internet Explorer 5.5+ */
+}
+
+address {
+ font-family: Georgia,
+ Times New Roman,
+ Arial,
+ sans-serif;
+ font-size: 12pt;
+}
+address.my {
+ text-align: right;
+}
\ No newline at end of file
--- /dev/null
+/************************************************************************/
+/* File: Print.css */
+/* Description: A printer version of the standard Cascading Style Sheet */
+/* definitions for site. This basically removes the menu */
+/* on the left hand side so that printed output is more */
+/* readable. */
+/* Author: Andrew@DeFaria.com */
+/* Created: Mon Jan 17 10:45:57 PST 2005 */
+/* Language: Cascading Style Sheet */
+/* */
+/* (c) Copyright 2005, Andrew@DeFaria.com, all rights reserved. */
+/* */
+/************************************************************************/
+@import url(Code.css);
+
+body {
+ background: white;
+ margin: 3px;
+ padding: 2px;
+ font-family: trebuchet MS,
+ trebuchet,
+ verdana,
+ sans-serif,
+ arial;
+ font-size: 14px;
+ color: black;
+}
+
+.heading {
+ margin-top: 5px;
+ padding: 5px;
+}
+
+/* Turn off menus */
+#imenus0 li a, #imenus0 .imctitle {
+ display: none;
+}
+
+#imouter0 {
+ display: none;
+}
+
+/* Turn off heading */
+.head {
+ display: none;
+}
+
+.filtered {
+ display: none;
+}
+
+h1, h2, h3, h4, h5 {
+ color: #00498b;
+ font-family: verdana,
+ sans-serif,
+ arial;
+}
+
+h1 {
+ text-align: center;
+}
+
+h1 {
+ font-size: 2em;
+}
+
+h2 {
+ font-size: 1.75em;
+}
+
+h3 {
+ font-size: 1.5em;
+}
+
+h4 {
+ font-size: 1.25em;
+}
+
+h5 {
+ font-size: 1em;
+}
+
+#content {
+ font-size: 16px;
+}
+
+#content p {
+ color: black;
+ font-family: arial,
+ trebuchet MS,
+ trebuchet,
+ verdana,
+ geneva,
+ helvetica,
+ sans-serif;
+ font-size: 16px;
+}
+
+/* Turn on underlining of links for clarity on paper */
+a {
+ color: #4A7184;
+ text-decoration: underline;
+ font-weight: bold;
+ font-family: trebuchet MS,
+ trebuchet,
+ verdana,
+ arial,
+ sans-serif;
+ font-size: 16px;
+ font-weight: bold;
+}
+
+a:link {
+ color: #0080c0;
+}
+
+/* For img's that happen to be links, don't put that silly */
+/* border! */
+img {
+ border: none;
+}
+
+font {
+ font-family: trebuchet MS,
+ trebuchet,
+ verdana,
+ arial,
+ sans-serif;
+ font-weight: normal;
+ text-transform: none;
+}
+
+p {
+ color: black;
+ font-family: arial,
+ trebuchet MS,
+ trebuchet,
+ verdana,
+ geneva,
+ helvetica,
+ sans-serif;
+ font-size: 16px;
+}
+
+ul {
+ color: black;
+ font-family: arial,
+ trebuchet MS,
+ trebuchet,
+ verdana,
+ geneva,
+ helvetica,
+ sans-serif;
+ font-size: 16px;
+}
+
+li {
+ font-family: arial,
+ trebuchet MS,
+ trebuchet,
+ verdana,
+ geneva,
+ helvetica,
+ sans-serif;
+ font-size: 16px;
+ line-height: 18px;
+}
+
+#foot p {
+ color: #aaa;
+ font-size: 80%;
+ text-align: center;
+ border-bottom: 1px dotted #ccc;
+ border-top: 1px dotted #ccc;
+}
+
--- /dev/null
+/************************************************************************/
+/* */
+/* File: TableBorders.css */
+/* Description: Define tables with borders */
+/* Author: Andrew@DeFaria.com */
+/* Created: Mon Nov 3 21:55:05 PST 2003 */
+/* Language: Cascading Style Sheet */
+/* */
+/* (c) Copyright 2004, Andrew@DeFaria.com, all rights reserved. */
+/* */
+/************************************************************************/
+
+/* Table headers */
+th.th {
+ border-style: solid;
+ border-color: black;
+ border-top-width: 2pt;
+ border-bottom-width: 0pt;
+ border-left-width: 1pt;
+ border-right-width: 0pt;
+ padding: 3px;
+ background: teal;
+ color: white;
+ font-size: 12px;
+}
+
+th.tht {
+ border-style: solid;
+ border-color: black;
+ border-top-width: 2pt;
+ border-bottom-width: 0pt;
+ border-left-width: 1pt;
+ border-right-width: 0pt;
+ padding: 3px;
+ background: teal;
+ color: white;
+ font-size: 16px;
+ -moz-border-radius-topleft: 10px;
+ -moz-border-radius-topright: 10px;
+}
+
+/* Table Header Top Left */
+th.thtl {
+ border-style: solid;
+ border-color: black;
+ border-top-width: 2pt;
+ border-bottom-width: 0pt;
+ border-left-width: 2pt;
+ border-right-width: 0pt;
+ padding: 3px;
+ background: teal;
+ color: white;
+ font-size: 12px;
+ -moz-border-radius-topleft: 10px;
+}
+
+/* Table Header Top Right */
+th.thtr {
+ border-style: solid;
+ border-color: black;
+ border-top-width: 2pt;
+ border-bottom-width: 0pt;
+ border-left-width: 1pt;
+ border-right-width: 2pt;
+ padding: 3px;
+ background: teal;
+ color: white;
+ font-size: 12px;
+ -moz-border-radius-topright: 10px;
+}
+
+/* Table Header Left */
+th.thl {
+ border-style: solid;
+ border-color: black;
+ border-top-width: 2pt;
+ border-bottom-width: 1pt;
+ border-left-width: 2pt;
+ border-right-width: 1pt;
+ padding: 3px;
+ background: teal;
+ color: white;
+ font-size: 12px;
+}
+
+/* Table Header Bottom Left */
+th.thbl {
+ border-style: solid;
+ border-color: black;
+ border-top-width: 1pt;
+ border-bottom-width: 2pt;
+ border-left-width: 2pt;
+ border-right-width: 1pt;
+ padding: 3px;
+ background: teal;
+ color: white;
+ font-size: 12px;
+}
+
+/* Table Data Top Left */
+td.tdtl {
+ border-style: solid;
+ border-color: black;
+ border-right-width: 0pt;
+ border-left-width: 2pt;
+ border-top-width: 2pt;
+ border-bottom-width: 0pt;
+ padding: 5px;
+ background: white;
+ color: black;
+ font-size: 12px;
+}
+
+/* Table Data Bottom Left */
+td.tdbl {
+ border-style: solid;
+ border-color: black;
+ border-right-width: 0pt;
+ border-left-width: 2pt;
+ border-top-width: 1pt;
+ border-bottom-width: 2pt;
+ padding: 5px;
+ background: white;
+ color: black;
+ font-size: 12px;
+}
+
+/* Table Data Bottom Right */
+td.tdbr {
+ border-style: solid;
+ border-color: black;
+ border-right-width: 2pt;
+ border-left-width: 1pt;
+ border-top-width: 1pt;
+ border-bottom-width: 2pt;
+ padding: 5px;
+ background: white;
+ color: black;
+ font-size: 12px;
+}
+
+/* Table Data Bottom */
+td.tdb {
+ border-style: solid;
+ border-color: black;
+ border-right-width: 0pt;
+ border-left-width: 1pt;
+ border-top-width: 1pt;
+ border-bottom-width: 2pt;
+ padding: 5px;
+ background: white;
+ color: black;
+ font-size: 12px;
+}
+
+/* Table Data */
+td.td {
+ border-style: solid;
+ border-color: black;
+ border-right-width: 0pt;
+ border-left-width: 1pt;
+ border-top-width: 1pt;
+ border-bottom-width: 0pt;
+ padding: 5px;
+ background: white;
+ color: black;
+ font-size: 12px;
+}
+
+/* Table Data Left */
+td.tdl {
+ border-style: solid;
+ border-color: black;
+ border-right-width: 0pt;
+ border-left-width: 2pt;
+ border-top-width: 1pt;
+ border-bottom-width: 0pt;
+ padding: 5px;
+ background: white;
+ color: black;
+ font-size: 12px;
+}
+
+/* Table Data Right */
+td.tdr {
+ border-style: solid;
+ border-color: black;
+ border-right-width: 2pt;
+ border-left-width: 1pt;
+ border-top-width: 1pt;
+ border-bottom-width: 0pt;
+ padding: 5px;
+ background: white;
+ color: black;
+ font-size: 12px;
+}
+
+/* Table Data Top Right */
+td.tdtr {
+ border-style: solid;
+ border-color: black;
+ border-right-width: 2pt;
+ border-left-width: 1pt;
+ border-top-width: 2pt;
+ border-bottom-width: 0pt;
+ padding: 5px;
+ background: white;
+ color: black;
+ font-size: 12px;
+}
+
+/* Table Data Top Right (right?) */
+td.tdtrr {
+ border-style: solid;
+ border-color: black;
+ border-right-width: 2pt;
+ border-left-width: 1pt;
+ border-top-width: 2pt;
+ border-bottom-width: 0pt;
+ padding: 5px;
+ background: white;
+ color: black;
+ font-size: 12px;
+ -moz-border-radius-topright: 10px;
+}
+
+/* Table Data Right */
+td.tdr {
+ border-style: solid;
+ border-color: black;
+ border-right-width: 2pt;
+ border-left-width: 1pt;
+ border-top-width: 1pt;
+ border-bottom-width: 0pt;
+ padding: 5px;
+ background: white;
+ color: black;
+ font-size: 12px;
+}
+
+/* Table Data Top */
+td.tdt {
+ border-style: solid;
+ border-color: black;
+ border-right-width: 0pt;
+ border-left-width: 1pt;
+ border-top-width: 2pt;
+ border-bottom-width: 0pt;
+ padding: 5px;
+ background: white;
+ color: black;
+ font-size: 12px;
+}
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+ <title>ClearSCM: Oops! Page not found</title>
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Article.css">
+ <link rel="stylesheet" type="text/css" media="print" href="/css/Print.css">
+ <link rel="SHORTCUT ICON" href="http://clearscm.com/favicon.ico" type="image/png">
+
+ <!-- Google Analytics
+ <script src="http://www.google-analytics.com/urchin.js" type="text/javascript">
+ </script>
+ <script type="text/javascript">
+ _uacct = "UA-89317-1";
+ urchinTracker ();
+ </script>
+ Google Analytics -->
+
+ <?php
+ include "php/clearscm.php";
+ menu_css ();
+ ?>
+</head>
+
+<body id="homepage">
+<?php heading ();?>
+
+<div id="page">
+ <div id="content">
+ <?php start_box ("cs2")?>
+ <h2><font color=red><b>ERROR:</b> Page not found</font></h2>
+ <?php end_box ();?>
+
+ <p>The page you were looking for was not found.</p>
+
+ <?php copyright ();?>
+</div>
+
+<script language="JavaScript" src="/JavaScript/Menus.js" type="text/javascript"></script>
+
+</body>
+</html>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=UTF-8">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+ <meta name="verify-v1" content="zmJmtrlhCOjGAk5w/JcwHaDsI3gxxRug9f4Vcl8YftU=" />
+
+ <title>ClearSCM</title>
+
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/FrontPage.css">
+ <link rel="stylesheet" type="text/css" media="print" href="/css/Print.css">
+ <link rel="SHORTCUT ICON" href="http://clearscm.com/favicon.ico" type="image/png">
+
+ <!-- Google Analytics
+ <script src="http://www.google-analytics.com/urchin.js" type="text/javascript">
+ </script>
+ <script type="text/javascript">
+ _uacct = "UA-89317-1";
+ urchinTracker ();
+ </script>
+ Google Analytics -->
+
+ <?php
+ include "php/clearscm.php";
+ menu_css ();
+ ?>
+</head>
+
+<body id="homepage" class="sm-r"> <!-- try r-sm, sm-r, ms-r or r-ms -->
+
+<?php heading ()?>
+
+<div id="page">
+ <div id="content">
+ <div id="contentWrapper2">
+ <div id="main">
+ <?php start_box ("cs3");?>
+ <p>We provide top notch talent for your <abbr title="Source Configuration Management">SCM</abbr> projects. With over 10
+ years of direct experience with the top <abbr title="Source Configuration Management">SCM</abbr> tools and
+ methodologies we have what it takes to help you succeed.</p>
+ <?php end_box ();?>
+
+ <h2>Our services</h2>
+ <img src="/Images/BMLeft.jpg" width="250" height="165"
+ style="float:left;border:1;padding:5px;" />
+
+ <p>You have your own business to run, your own set of
+ problems, deadlines, challenges and schedules. You want
+ talent to come in and hit the ground running, tackling your
+ toughest challenges. We offer consulting services in the
+ areas of SCM, Build & Release management, Systems
+ Administration and customized scripting solutions.</p>
+
+ <p>ClearSCM, Inc. provides consultants who have technical
+ expertise coupled with an in-depth knowledge of the business
+ process to Fortune 500 companies and other Organizations
+ nationwide and around the world. Our senior consultants and
+ specialists in the computer industry specialize in
+ implementing SCM and ECM for your business needs. We can
+ customize your SCM and maintain your application. We provide
+ a comprehensive technology to help clients successfully
+ build, deploy and manage mission critical enterprise
+ applications in an open systems environment.
+ </div> <!-- main -->
+
+ <div id="supporting">
+ <?php start_box ("cs2");?>
+ <h2><abbr title="Source Configuration Management">SCM</abbr>
+ & <abbr title="Enterprise Change Management">ECM</abbr></h2>
+ <p>Utilizing top tier professional tools such as <a
+ href="http://www.ibm.com/software/awdtools/clearcase/index.html">Clearcase</a>,
+ <a
+ href="http://www.ibm.com/software/awdtools/clearcase/multisite/index.html">Multisite</a>,
+ <a
+ href="http://www.ibm.com/software/awdtools/clearquest/index.html">Clearquest</a>
+ as well as various Open Source tools such as <abbr
+ title="Concurrent Versions System: A free and commonly
+ used Open Source SCM system">CVS</abbr> we work with your
+ company to build professional, customized solutions to
+ your <abbr title="Source Configuration Management">SCM</abbr> needs.</p>
+ <?php end_box ();?>
+
+ <?php start_box ("cs3");?>
+ <h2>Beyond SCM</h2>
+ <p>Rarely do companies live on SCM alone. There are many
+ internal and inhouse systems that grow up around Build and
+ Release Management systems including things like internal
+ web sites tracking nightly build processes. Integrations
+ between bug tracking systems and source control
+ systems. Many times such intergrations have yet to be
+ made... <a href="/services">(more)</a>
+ <?php end_box ();?>
+ </div> <!-- supporting -->
+ </div> <!-- contentWrapper2 -->
+
+ <div id="contentWrapper1">
+ <div id="related">
+ <?php start_box ("cs2");?>
+ <h2>Systems Administration</h2>
+ <p>Whether large or small, today's software is more
+ complex. Many resources are brought to bear to get your
+ code from inception to release.... <a
+ href="/sysadm">(more)</a></p>
+ <?php end_box ();?>
+
+ <?php start_box ("cs5");?>
+
+ <h2>Scripting Expertise</h2>
+ <p>Over the years there have been many languages that have
+ come about. Each have their strengths and places in a
+ professionals <i>bag of tricks</i>. Perl is very good as a
+ "glue" language bringing together various other systems,
+ home grown as well as purchased packages, to help build
+ larger, customized solutions for your business...<a
+ href="/sysadm">(more)</a></p>
+ <?php end_box ();?>
+ </div> <!-- related -->
+ </div> <!-- contentWrapper1 -->
+ </div> <!-- content -->
+
+ <?php copyright();?>
+</div> <!-- page -->
+
+<script language="JavaScript" src="/JavaScript/Menus.js" type="text/javascript"></script>
+
+</body>
+</html>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+ <title>ClearSCM: Our People</title>
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Article.css">
+ <link rel="stylesheet" type="text/css" media="print" href="/css/Print.css">
+ <link rel="SHORTCUT ICON" href="http://clearscm.com/favicon.ico" type="image/png">
+
+ <!-- Google Analytics
+ <script src="http://www.google-analytics.com/urchin.js" type="text/javascript">
+ </script>
+ <script type="text/javascript">
+ _uacct = "UA-89317-1";
+ urchinTracker ();
+ </script>
+ Google Analytics -->
+
+ <?php
+ include "php/clearscm.php";
+ menu_css ();
+ ?>
+</head>
+
+<body id="homepage">
+<?php heading ();?>
+
+<div id="page">
+ <div id="content">
+ <?php start_box ("cs2")?>
+ <h2>Our People</h2>
+ <?php end_box ();?>
+
+ <h3>Andrew DeFaria</h3>
+
+ <p><b>Specialities:</b> Clearcase, Clearquest, Build & Release,
+ Test Automation, Web Applications</p>
+
+ <img style="float:right" src="/Images/AndrewDeFaria.jpg">
+ <p>Andrew has approximately 30 years of experience in the computer
+ field and has been working with Clearcase since ~1993. His initial
+ exposure to Clearcase was at Hewlett Packard's Language Lab where he
+ become the Clearcase adminstrator as well as general Unix
+ administrator. Andrew has continued to work with Clearcase,
+ Clearquest as well as Unix and Windows administration, Build &
+ Release processes, Test Automation and has added on various Web
+ Applications at numbers Fortune 500 and Fortune 100 companies such
+ as HP, Sun, Cisco, Ameriquest, Broadcom and Texas
+ Instruments.</p>
+
+ <p>Andrew is the president of ClearSCM, Inc. and it the principal
+ writer, designer and implementor of this web site. He also runs his
+ own domain at <a href="http://defaria.com">defaria.com</a> where he
+ keeps his administration skills sharp and develops web
+ applications. For example, Andrew has developed a personal spam
+ filtering system known as Mail Authorization and Permission System
+ or MAPS that filters the some 2000-5000 emails he receives a day!
+ Andrew also keeps active on various mail lists and forums regarding
+ topics from SCM to ones of a personal nature.</p>
+
+ <p>For more detailed information see <a
+ href="/Resumes/Andrew">Andrew's Resume</a>.</p>
+
+ <br><hr>
+ <img style="float:left" src="Resumes/Tom/Tom.png" alt="Tom Connor">
+ <h3>Tom Connor</h3>
+
+ <p><b>Specialities</b> Clearcase, UCM, Clearquest, Build/Release, Perl</p>
+
+ <p>Tom is a Sr. Software Engineer with over 20 years of varied
+ experience as a software developer. Specializations in
+ Software Configuration Management, Release Engineering, Build
+ Engineering, workflow automation, Installer Development, and
+ Deployment Engineering. Creative problem solver with strong
+ analytical and communication skills.</p>
+
+ <p>For more information see <a href="Resumes/Tom">Tom's
+ Resume</a>.</p>
+
+ <hr>
+
+ <h3>Kevin Haralson</h3>
+
+ <p><b>Specialities</b> System Adminstration, Managing vendor
+ relationships, IT Tech/Helpdesk expertise</p>
+
+ <p>19 years experience in the IT field. 5 years as a manager,
+ overseeing projects, and/or budgets. 4 years in a technical sales
+ capacity, and 10 years as a Technician (Tech Support/Helpdesk to
+ Desktop/Hardware/Config Tech to System Admin to Network Admin).</p>
+
+ <p>In the last 3 years I have been involved in building the
+ infrastructure for medical, legal and financial offices, including
+ installing most/ all of their industry specific software. I've
+ worked in three large organizations (over 2000 employees) as an IT
+ Tech, and a number of smaller organizations (20 - 200 employees)
+ from help desk to director of IT.</p>
+
+ <p>For more information see <a href="Resumes/Kevin">Kevin's
+ Resume</a>.</p>
+
+ <hr>
+
+ <h3>Don Skanes</h3>
+
+ <p><b>Specialities</b> Clearcase, Clearquest, Windows, Project Management</p>
+
+ <p>Don, originally from Canada, is a highly skilled senior software
+ engineer with over 27 years of experience. Special strengths in the
+ areas of design and implementation of Software Configuration
+ Management tools, operating systems, programming languages,
+ compilers, databases, system validation tools, build and deployment
+ automation.</p>
+
+ <p>Don has been working with Clearcase since the early 90's. He has
+ a firm grasp of the Rational Toolset including the Team Unifying
+ Platorm, UCM, Clearquest, Test Director. Don is equally comfortable
+ in a management role as he is in a role of designer and
+ developer. Whether writing project plans, training material or
+ coding Clearcase triggers or build automation tools,</p>
+
+ <p>For more information see <a
+ href="/Resumes/Don">Don's Resume</a>.</p>
+
+ <hr>
+
+ <h3>Ron Van Sherpe</h3>
+
+ <p><b>Specialities:</b> Windows Administration, Unix/Linux
+ Administration and advocate</p>
+
+ <p>Ron is one of those people who loves technology and loves to put
+ different technological ideas together building solutions for
+ clients. He is a strong advocate of Linux and has put together many
+ packages for small companies to use Open Source packages with Linux
+ backends to solve their corporate business needs as cheaply as
+ possible.</p>
+
+ <p>For more information see <a href="/Resumes/Ron">Ron's Resume</a>.</p>
+
+ <hr>
+
+ <h3>Mohammed Ansari</h3>
+
+ <p><b>Specialities:</b> With more than 15 years experience Mohammed
+ specializes as a Configuration Management Program and Project Lead.</p>
+
+ <p>Mohammed's experience is one who's breath is about as broad as his
+ depth. Mohammed specializes in Configuration management from a project
+ and program perspective but has years of depth in the trenches as well.</p>
+
+ <p>For more information see <a href="/Resumes/Mohammed">Mohammed's Resume</a>.</p>
+
+ <hr>
+
+ <?php copyright ();?>
+</div>
+
+<script language="JavaScript" src="/JavaScript/Menus.js" type="text/javascript"></script>
+
+</body>
+</html>
--- /dev/null
+<?php
+////////////////////////////////////////////////////////////////////////////////
+//
+// File: $RCSfile: clearscm.php,v $
+// Revision: $Revision: 1.23 $
+// Description: Reports large files
+// Author: Andrew@DeFaria.com
+// Created: Wed Apr 11 18:37:09 2007
+// Modified: $Date: 2013/03/18 22:46:55 $
+// Language: Php
+//
+// (c) Copyright 2007, ClearSCM Inc., all rights reserved
+//
+////////////////////////////////////////////////////////////////////////////////
+$base = $_SERVER['DOCUMENT_ROOT'];
+
+function menu_css () {
+ global $base;
+
+ $lines = @file ("$base/css/Menus.css")
+ or die ("Unable to open $base/css/Menus.css");
+
+ print "<style type=\"text/css\">\n";
+
+ foreach ($lines as $line) {
+ print $line;
+ } // foreach
+
+ print "</style>";
+} // menu_css
+
+function menu () {
+ print <<<END
+<div class="imrcmain0 imgl" style="width:100%;z-index:999999;position:relative;">
+ <div class="imcm imde" id="imouter0">
+ <ul id="imenus0">
+ <li class="imatm" style="width:100px;"><a href="/"><span class="imea imeam"></span>Home</a></li>
+
+ <li class="imatm" style="width:145px;">
+ <a class="" href="/services"><span class="imea imeam"><span></span></span>Services</a>
+
+ <div class="imsc">
+ <div class="imsubc" style="width:145px;top:0px;left:0px;">
+ <ul style="">
+ <li><a href="/services/consultancy.php">Consultancy</a></li>
+ <li><a href="/services/custom_software.php">Custom Software Solutions</a></li>
+ <li><a href="/services/sysadmin.php">Systems Adminsitration</a></li>
+ <li><a href="/services/web.php">Web Applications</a></li>
+ <li><a href="/services/customers.php">Customers</a></li>
+ </ul>
+ </div>
+ </div>
+ </li>
+
+ <li class="imatm" style="width:145px;">
+ <a class="" href="/services/scm"><span class="imea imeam"><span></span></span>SCM</a>
+
+ <div class="imsc">
+ <div class="imsubc" style="width:145px;top:0px;left:0px;">
+ <ul style="">
+ <li><a href="/clearcase"><span class="imea imeas"><span></span></span>Clearcase</a>
+ <div class="imsc">
+ <div class="imsubc" style="width:140px;top:-23px;left:132px;">
+ <ul style="">
+ <li><a href="/clearcase/triggers.php">Triggers</a></li>
+ <li><a href="/php/cvs_man.php?file=cc/etf.pl">Evil Twin Finder</a></li>
+ <li><a href="/php/cvs_man.php?file=cc/diffbl.pl">GUI DiffBL</a></li>
+ <li><a href="/php/cvs_man.php?file=cc/viewager.cgi">View Ager</a></li>
+ <li><a href="/clearcase/OpenSourceBuild.php/">Open Source Builds</a></li>
+ </ul>
+ </div>
+ </div>
+ </li>
+ <li><a href="/clearquest"><span class="imea imeas"><span></span></span>Clearquest</a>
+ <div class="imsc">
+ <div class="imsubc" style="width:140px;top:-23px;left:132px;">
+ <ul style="">
+ <li><a href="/clearquest/cqd">Clearquest Daemon</a></li>
+ <li><a href="/clearquest/db.php">DB Conversions</a></li>
+ </ul>
+ </div>
+ </div>
+ </li>
+ <li><a href="/cvs"><span class="imea imeas"><span></span></span>CVS</a>
+ <div class="imsc">
+ <div class="imsubc" style="width:140px;top:-23px;left:132px;">
+ <ul style="">
+ <li><a href="/viewvc/clearscm.com/">Respository</a></li>
+ </ul>
+ </div>
+ </div>
+ </li>
+ </ul>
+ </div>
+ </div>
+ </li>
+
+ <li class="imatm" style="width:145px;"><a href="/scripts"><span class="imea imeam"><span></span></span>Scripting</a>
+ <div class="imsc">
+ <div class="imsubc" style="width:146px;top:0px;left:0px;">
+ <ul style="">
+ <li><a href="/scripts/perl.php">Perl</a></li>
+ <li><a href="/scripts/ecrd">ECRDig</a></li>
+ </ul>
+ </div>
+ </div>
+ </li>
+
+ <li class="imatm" style="width:145px;"><a href="/sysadm"><span class="imea imeam"><span></span></span>Sysadm</a>
+ <div class="imsc">
+ <div class="imsubc" style="width:146px;top:0px;left:0px;">
+ <ul style="">
+ <li><a href="/sysadm/env">Environment</a></li>
+ </ul>
+ </div>
+ </div>
+ </li>
+
+ <li class="imatm" style="width:145px;"><a href="#"><span class="imea imeam"><span></span></span>About</a>
+ <div class="imsc">
+ <div class="imsubc" style="width:146px;top:0px;left:0px;">
+ <ul style="">
+ <li><a href="/services">Services</a></li>
+ <li><a href="/people.php">Our People</a></li>
+ <li><a href="/contact.php">Contact Us</a></li>
+ </ul>
+ </div>
+ </div>
+ </li>
+ </ul>
+
+ <div class="imclear"> </div>
+ </div>
+</div>
+END;
+} // menu
+
+function heading () {
+ print "<div id=head>";
+ menu ();
+ print <<<END
+ <h1 style="color:#fff;text-align:center;font-size:3em">ClearSCM Inc.</h1>
+
+ <div class="filtered">
+ <p><strong>You are viewing an unstyled version of this
+ page.</strong> Either your browser does not support Cascading
+ Style Sheets (CSS) or CSS styling has been disabled.</p>
+ </div>
+END;
+} // heading
+
+function start_box ($type) {
+ print <<<END
+<!--B--> <div class="rcbox"><div class="$type"><b class="xtop"><b class="xb1"></b><b class="xb2"></b><b class="xb3"></b><b class="xb4"></b></b><div class="xboxcontent">
+END;
+} // start_box
+
+function end_box () {
+ print <<<END
+<!--A--> </div><b class="xbottom"><b class="xb4"></b><b class="xb3"></b><b class="xb2"></b><b class="xb1"></b></b></div></div>
+END;
+} // end_box
+
+function search_box () {
+ print <<<END
+<div id="search">
+ <!-- Start: Search my site with Google -->
+ <form method="get" action="http://www.google.com/search" name="search">
+ <div>Search my site
+ <input type="text" name="q" size="15" id="q" maxlength=255 value=""
+ onclick="document.search.q.value='';">
+ <input type="hidden" name="domains" value="clearscm.com">
+ <input type="hidden" name="sitesearch" value="clearscm.com">
+ </div>
+ </form>
+ <!-- End: Search my site with Google -->
+</div>
+<br>
+END;
+} // search_box
+
+function copyright ($start_year = "",
+ $author = "Andrew DeFaria",
+ $email = "info@clearscm.com",
+ $home = "") {
+ global $base;
+ global $base1;
+
+ $today = getdate ();
+ $current_year = $today ["year"];
+
+ $this_file = $base1 . "/" . $_SERVER['PHP_SELF'];
+
+ $mod_time = date ("F d Y @ g:i a", filemtime ($this_file));
+
+ print <<<END
+<div id="foot"><p>
+ Last modified: $mod_time<br>
+ Copyright ©
+END;
+
+ if ($start_year != "") {
+ print "$start_year-";
+ } // if
+
+print <<<END
+$current_year, ClearSCM Inc. - All rights reserved
+</p></div>
+END;
+} // copyright
+
+function get_file_from_cvs ($file,
+ $machine = "clearscm.com",
+ $port = ":8080",
+ $path = "/viewvc/clearscm.com/") {
+ $user = "andrew";
+ $password = "airafed";
+ $url = "http://$user:$password@$machine$port$path$file?view=co";
+
+ $contents = @file ($url)
+ or die ("$url not found");
+
+ return $contents;
+} # get_file_from_cvs
+
+function display_contents_as_code ($contents) {
+ print "<div class=code>";
+ print "<table id=listing cellspacing=0 cellpadding=2 border=0 width=90%>";
+
+ $line_number = 1;
+
+ foreach ($contents as $line) {
+ print "<tr>";
+ print " <td id=line-number><a name=line_$line_number></a>" .
+ $line_number++ . "</td>";
+ print " <td id=code><tt>";
+
+ for ($i = 0; $i < strlen ($line); $i++) {
+ if ($line [$i] == " ") {
+ if ($i == 0 && $line_number == 2) {
+ continue;
+ } // if
+ echo " ";
+ } else if ($line [$i] == "\t") {
+ echo " ";
+ } else if ($line [$i] != "\n") {
+ echo $line [$i];
+ } // if
+ } // for
+
+ print "</tt></td>";
+ print "</tr>\n";
+ } // foreach
+
+ print "</table>";
+ print "</div>";
+} // display_contents_as_code
+
+function display_contents_as_snippet ($contents) {
+ print "<div class=code>";
+
+ foreach ($code as $line) {
+ for ($i = 0; $i < strlen ($line); $i++) {
+ if ($line [$i] == " ") {
+ echo " ";
+ } else if ($line [$i] == "\t") {
+ echo " ";
+ } else if ($line [$i] != "\n") {
+ echo $line [$i];
+ } // if
+ } // for
+ } // foreach
+
+ print "</div>";
+} // display_contents_as_snippet
+
+function display_code ($file,
+ $machine = "clearscm.com",
+ $port = ":8080",
+ $path = "/viewvc/clearscm.com/") {
+ display_contents_as_code (get_file_from_cvs ($file, $machine, $port, $path));
+} # display_code
+
+function cvs_man ($file,
+ $machine = "clearscm.com",
+ $port = ":8080",
+ $path = "/viewvc/clearscm.com/") {
+
+ $desc_spec = array (
+ 0 => array ("pipe", "r"), // stdout
+ 1 => array ("pipe", "w"), // stdin
+ 2 => array ("pipe", "w"), // stderr
+ );
+
+ $pod2html = proc_open ("pod2html -cachedir /tmp -noindex -htmlroot=http://perldoc.perl.org", $desc_spec, $pipes);
+
+ if (!is_resource ($pod2html)) {
+ die ("Unable to start pod2html");
+ } // if
+
+ $stdin = $pipes [0];
+ $stdout = $pipes [1];
+ $stderr = $pipes [2];
+
+ $contents = get_file_from_cvs ($file, $machine, $port, $path);
+
+ // Write to stdin
+ foreach ($contents as $line) {
+ fwrite ($stdin, $line);
+ } // foreach
+ fclose ($stdin);
+
+ $end_of_index = 0;
+ $pre_just_ended = 0;
+ $machine = "clearscm.com";
+ $port = "";
+ $path = "/viewvc/clearscm.com/";
+ $url = "http://$machine$port$path$file?view=co";
+ $history = "http://$machine$port$path$file";
+
+ // Now get the output and write it out
+ while (!feof ($stdout)) {
+ $line = fgets ($stdout);
+
+ if (preg_match ("/<!-- INDEX END -->/", $line)) {
+ $end_of_index = 1;
+ continue;
+ }
+
+ if (!$end_of_index) {
+ continue;
+ } // if
+
+ // Filter some CVS keywords properly
+ $line = preg_replace ("/\\\$Revision\:\s*(\S*)\s*\\\$/",
+ "Revision <a href=\"$history\">$1</a>",
+ $line);
+ $line = preg_replace ("/\\\$Date\:\s*(.*)\s*\\\$/",
+ "Modifed $1",
+ $line);
+ $line = preg_replace ("/\\\$RCSfile\:\s*(\S*),v\s*\\\$/",
+ "$1",
+ $line);
+
+ // Collapse adjacent <pre> sections to instead have a simple blank
+ // line
+ if (preg_match ("/<\/pre>$/", $line)) {
+ $line = preg_replace ("/<\/pre>/", "", $line);
+ print "$line\n";
+ $pre_just_ended = 1;
+ continue;
+ } // if
+
+ if (preg_match ("/^<pre>$/", $line)) {
+ if ($pre_just_ended) {
+ $pre_just_ended = 0;
+ continue;
+ } // if
+ } else {
+ if ($pre_just_ended) {
+ $pre_just_ended = 0;
+ echo "</pre></div>$line";
+ continue;
+ } // if
+ } // if
+
+ $line = preg_replace ("/<pre>/",
+ "<div class=code><pre>",
+ $line);
+ $line = preg_replace ("/<\/pre>/",
+ "</pre></div>",
+ $line);
+ $line = preg_replace ("/<a name=.*>(.*)<\/a>/",
+ "$1",
+ $line);
+ $line = preg_replace ("/NAME (\S*)<\/h1>/",
+ "NAME $1 <a href=\"$url\"><img src=\"/Icons/Download.jpg\" border=0 title=Download></a></h1>",
+ $line);
+ $line = preg_replace ("/NAME (\S*)<\/h2>/",
+ "NAME $1 <a href=\"$url\"><img src=\"/Icons/Download.jpg\" border=0 title=Download></a></h2>",
+ $line);
+ echo $line;
+ } // while
+
+ fclose ($stdout);
+
+ //while (!feof ($stderr)) {
+ // echo fgets ($stderr) . "<br>";
+ //} // while
+
+ fclose ($stderr);
+
+ proc_close ($pod2html);
+} // cvs_man
+?>
--- /dev/null
+<?php
+$cvs_file = $_REQUEST["file"];
+?>
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=UTF-8">
+ <title>ClearSCM: <?php echo $cvs_file?></title>
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/ManPage.css">
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Code.css">
+ <link rel="stylesheet" type="text/css" media="print" href="/css/Print.css">
+ <link rel="SHORTCUT ICON" href="http://clearscm.com/favicon.ico" type="image/png">
+
+ <!-- Google Analytics
+ <script src="http://www.google-analytics.com/urchin.js" type="text/javascript">
+ </script>
+ <script type="text/javascript">
+ _uacct = "UA-89317-1";
+ urchinTracker ();
+ </script>
+ Google Analytics -->
+ <?php
+ include "clearscm.php";
+ menu_css ();
+ ?>
+</head>
+
+<div id="homepage">
+<?php heading ();?>
+
+<div id="page">
+ <div id="content">
+ <?php cvs_man ($cvs_file);?>
+ </div>
+</div>
+
+<script language="JavaScript" src="/JavaScript/Menus.js" type="text/javascript"></script>
+
+</body>
+</html>
--- /dev/null
+<?php phpinfo()?>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"\r
+ "http://www.w3.org/TR/html4/strict.dtd">\r
+<html>\r
+<head>\r
+\r
+ <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">\r
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">\r
+ <title>ECR 23184: Native PPC Toolchain build failing (atoi missing)</title>\r
+ <link rel="stylesheet" type="text/css" media="screen" href="DefaultPlain.css">\r
+ <link rel="stylesheet" type="text/css" href="/css/TableBorders.css">\r
+ <link rel="icon" href="http://www.lynuxworks.com/favicon.ico">\r
+</head>\r
+\r
+<div class="heading">\r
+ <h1 class="centered">ECR 23184: Native PPC Toolchain build failing (atoi missing)</h1>\r
+</div>\r
+\r
+<div id="content">\r
+<center><font class=label>State:</font> <font class=data>Pending Review</font> <font class=label>Status:</font> <font class=data>Duplicate</font> <font class=label>Severity:</font> <font class=data>Medium</font> <font class=label>Fixed:</font> <font class=data></font> </center><hr><pre>\r
+\r
+###### adefaria: 24 Jan 2005 10:50:45 (-00:05)\r
+\r
+I am unable to build the toolchain natively on t-mcpn765-1 (PPC). Note \r
+I am trying to use XFree86 however the problem seems to be with atoi:\r
+\r
+gcc tkAppInit.o -L/mnt/toolchain/3.2.2/010405/build-powerpc/tk/unix \r
+-ltk8.0 -L/mnt/toolchain/3.2.2/010405/build-powerpc/tcl/unix -ltcl8\r
+.0 -L/usr/X11R6/lib -lX11 -lc \\r
+ -o wish\r
+/usr/X11R6/lib/libX11.a(ConnDis.o): In function \r
+`_X11TransConnectDisplay':\r
+ConnDis.o(.text+0x2ac): undefined reference to `atoi'\r
+ConnDis.o(.text+0x344): undefined reference to `atoi'\r
+/usr/X11R6/lib/libX11.a(lcGeneric.o): In function \r
+`read_charset_define':\r
+lcGeneric.o(.text+0x8cc): undefined reference to `atoi'\r
+lcGeneric.o(.text+0x928): undefined reference to `atoi'\r
+/usr/X11R6/lib/libX11.a(lcGeneric.o): In function \r
+`read_segmentconversion':\r
+lcGeneric.o(.text+0xd7c): undefined reference to `atoi'\r
+/usr/X11R6/lib/libX11.a(lcGeneric.o)(.text+0x1324): more undefined \r
+references to `atoi' follow\r
+collect2: ld returned 1 exit status\r
+make[3]: *** [wish] Error 1\r
+make[2]: *** [all] Error 2\r
+make[1]: *** [all-tk] Error 2\r
+make: *** [stamp-all-powerpc] Error 2\r
+\r
+I spoke with Adam about this and he said the problem is in libc.a, \r
+which lacks an atoi:\r
+\r
+# nm /lib/libc.a | grep atoi\r
+catoi.as.o:\r
+00000038 T catoi\r
+00000124 t regatoi\r
+\r
+Adam also said that Steve might know if there was a recent change.\r
+-- \r
+Andrew DeFaria <adefaria@lnxw.com>\r
+Build & Release\r
+QA\r
+LynuxWorks\r
+\r
+\r
+\r
+###### oleg (quintus): 14 Feb 2005 05:45:20\r
+\r
+This ECR <a href="/ecr/ecr.php?ecr="></a>is a duplicate of ECR <a href="/ecr/ecr.php?ecr=22979">22979</a>.\r
+</hr></pre></div>\r
+</html>\r
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+ <title>ClearSCM: Scripts: ECRC: </title>
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Article.css">
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Code.css">
+ <link rel="stylesheet" type="text/css" media="print" href="/css/Print.css">
+ <link rel="SHORTCUT ICON" href="http://clearscm.com/favicon.ico" type="image/png">
+
+ <!-- Google Analytics
+ <script src="http://www.google-analytics.com/urchin.js" type="text/javascript">
+ </script>
+ <script type="text/javascript">
+ _uacct = "UA-89317-1";
+ urchinTracker ();
+ </script>
+ Google Analytics -->
+
+ <?php
+ include "../../php/clearscm.php";
+ menu_css ();
+ ?>
+</head>
+
+<body>
+
+<?php heading ();?>
+
+<div id="page">
+ <div id="content">
+ <?php start_box ("cs5");?>
+ <h2>ECRD Daemon</h2>
+
+ <p>This is a client script that calls ecrd.</p>
+ <?php end_box ();?>
+
+ <?php display_code ("ecrc/ecrc");?>
+ </div>
+ <?php copyright ();?>
+</div>
+
+<script language="JavaScript" src="/JavaScript/Menus.js" type="text/javascript"></script>
+
+</body>
+</html>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+ <title>ClearSCM: Scripts: ECRD: </title>
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Article.css">
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Code.css">
+ <link rel="stylesheet" type="text/css" media="print" href="/css/Print.css">
+ <link rel="SHORTCUT ICON" href="http://clearscm.com/favicon.ico" type="image/png">
+
+ <!-- Google Analytics
+ <script src="http://www.google-analytics.com/urchin.js" type="text/javascript">
+ </script>
+ <script type="text/javascript">
+ _uacct = "UA-89317-1";
+ urchinTracker ();
+ </script>
+ Google Analytics -->
+
+ <?php
+ include "../../php/clearscm.php";
+ menu_css ();
+ ?>
+</head>
+
+<body>
+
+<?php heading ();?>
+
+<div id="page">
+ <div id="content">
+ <?php start_box ("cs5");?>
+ <h2>ECRC API</h2>
+
+ <p>This is the PHP API for ecrc.</p>
+ <?php end_box ();?>
+
+ <?php display_code ("ecrc/ecrc.php");?>
+ </div>
+ <?php copyright ();?>
+</div>
+
+<script language="JavaScript" src="/JavaScript/Menus.js" type="text/javascript"></script>
+
+</body>
+</html>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+ <title>ClearSCM: Scripts: ECRD: </title>
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Article.css">
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Code.css">
+ <link rel="stylesheet" type="text/css" media="print" href="/css/Print.css">
+ <link rel="SHORTCUT ICON" href="http://clearscm.com/favicon.ico" type="image/png">
+
+ <!-- Google Analytics
+ <script src="http://www.google-analytics.com/urchin.js" type="text/javascript">
+ </script>
+ <script type="text/javascript">
+ _uacct = "UA-89317-1";
+ urchinTracker ();
+ </script>
+ Google Analytics -->
+
+ <?php
+ include "../../php/clearscm.php";
+ menu_css ();
+ ?>
+</head>
+
+<body>
+
+<?php heading ();?>
+
+<div id="page">
+ <div id="content">
+ <?php start_box ("cs5");?>
+ <h2>ECRD Daemon</h2>
+
+ <p>This is a daemon script that opens a database and waits for requests for service by reading a socket. When requests come in it responds with the data for an ECR record from the database.</p>
+ <?php end_box ();?>
+
+ <?php display_code ("ecrc/ecrd");?>
+ </div>
+ <?php copyright ();?>
+</div>
+
+<script language="JavaScript" src="/JavaScript/Menus.js" type="text/javascript"></script>
+
+</body>
+</html>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+
+ <title>ClearSCM: ECRDig</title>
+
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Article.css">
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Code.css">
+ <link rel="stylesheet" type="text/css" media="print" href="/css/Print.css">
+ <link rel="SHORTCUT ICON" href="http://clearscm.com/favicon.ico" type="image/png">
+
+ <!-- Google Analytics
+ <script src="http://www.google-analytics.com/urchin.js" type="text/javascript">
+ </script>
+ <script type="text/javascript">
+ _uacct = "UA-89317-1";
+ urchinTracker ();
+ </script>
+ Google Analytics -->
+
+ <?php
+ include "../../php/clearscm.php";
+ menu_css ();
+ ?>
+</head>
+
+<body id="homepage">
+
+<?php heading ();?>
+
+<div id="page">
+ <div id="content">
+ <?php start_box ("cs3");?>
+ <h2>ECRDig</h2>
+
+ <h4 style="text-align:center">by <a
+ href="/people.php">Andrew DeFaria</a></h4>
+
+ <p>ECRs, or Electronic Change Records, was a bug tracking
+ systems in used at <a href="http://lynuxworks.com">LynuxWorks,
+ Inc.</a>. What started as a simple quest to display an ECR as a
+ web pages turned into a full blown, full text search of the
+ defect/issue tracking system. Here's how it developed...</p>
+ <?php end_box ();?>
+
+ <h3>Introduction</h3>
+
+ <p>While at LynuxWorks I decided to leverage some code that I had
+ previously developed (See <a href="/clearquest/cqd">Clearquest
+ Daemon</a>) that utilizes a client/server model to provide a
+ service that interogates a database and returns information. Again
+ this database happens to be a defect tracking database residing on
+ another machine.</p>
+
+ <h3>Daemon</h3>
+
+ <p>The daemon opens the database then listens on a socket for
+ requests, in this case a defect ID, then obtains the detail
+ information about the defect and returns it to the caller in the
+ form of a Perl hash. This avoids the overhead associated with
+ opening and closing the database or otherwise connecting to the
+ datastore. The daemon runs continually in the background listening
+ for and servicing requests (<a href="ecrd.php">ecrd source
+ code</a>).</p>
+
+ <h3>Client</h3>
+
+ <p>The caller, or client, then can process the information in
+ anyway they see fit. Often the caller is a Perl or PHP script that
+ outputs the information in to a nicely formatted web page but it
+ can as easily be a command line tool that spits out the answer to
+ a question. For example:<p>
+
+ <div class="code"><pre>
+ $ ecrc 142 owner
+ adefaria
+ </pre></div>
+
+ <p>uses a command line client to display the owner of the defect
+ 142. (<a href="ecrc.php">ecrc source code</a>).</p>
+
+ <h3>PHP Module</h3>
+
+ <p>As PHP is a nice language for writing dynamic web pages I then
+ developed a PHP API library in order to be a client to ecrd which
+ was written in Perl. This allowed me to call the daemon to get
+ information about a defect then format out whatever web page I
+ wanted (<a href="ecrc.php.php">ecrc.php API source code</a>).</p>
+
+ <p>For example, here is an <a href="ecr23184.html">example</a> of
+ a web page describing a specific defect. Notics that the ECR
+ (LynuxWorks defect tracking system) displays the one line
+ description as well as other fields such as State, Status,
+ Severity and Fixed info. Additionally the long description is
+ displayed as well as parsed for references to other ECRs or
+ auxilary files, courtesy of PHP.</p>
+
+ <table border=0 align=right width=300px>
+ <tr>
+ <td>
+ <?php start_box ("cs2");?>
+ <p>The link to ECR 22979 will not work unless you are
+ within the LynuxWorks Intranet</p>
+ <?php end_box ();?>
+ </td>
+ </tr>
+ </table>
+
+ <h3>Tying it into HtDig</h3>
+
+ <p>Since ECRs and their full text descriptions are now available
+ via a web link it was relatively trival to hook this up to <a
+ href="http://www.htdig.org/">HtDig</a> to enable full text
+ searching on all ECRs and their descriptions. All that was needed
+ was to produce a web page with all ECRs listed linked to web pages
+ of their descriptions. HtDig would then crawl through and index
+ everything. Additionally, since the ECR descriptions were scanned
+ for references to certain <i>auxilary files</i> (files not
+ necessarily in the defect database but on a network accessible
+ area and used to further support the ECR in question) HtDig would
+ crawl through and index them too. This resulted in a very flexible
+ and powerful internal search facility.</p>
+ </div>
+
+ <?php copyright ();?>
+</div>
+
+<script language="JavaScript" src="/JavaScript/Menus.js" type="text/javascript"></script>
+
+</body>
+</html>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+
+ <title>ClearSCM: Scripting</title>
+
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Article.css">
+ <link rel="stylesheet" type="text/css" media="print" href="/css/Print.css">
+ <link rel="SHORTCUT ICON" href="http://clearscm.com/favicon.ico" type="image/png">
+
+ <!-- Google Analytics
+ <script src="http://www.google-analytics.com/urchin.js" type="text/javascript">
+ </script>
+ <script type="text/javascript">
+ _uacct = "UA-89317-1";
+ urchinTracker ();
+ </script>
+ Google Analytics -->
+
+ <?php
+ include "../php/clearscm.php";
+ menu_css ();
+ ?>
+</head>
+
+<body id="homepage">
+<?php heading ();?>
+
+<div id="page">
+ <div id="content">
+ <?php start_box ("cs4")?>
+ <h2>Scripting Expertise</h2>
+ <?php end_box ();?>
+
+ <p>Over the years there have been many languages that have come
+ about. Each have their strengths and places in a professionals bag
+ of tricks. Perl is very good as a "glue" language bringing
+ together various other systems, home grown as well as purchased
+ packages, to help build larger, customized solutions for your
+ business. PHP, on the other hand, grew up on the web and is
+ excellent for web applications. In fact we use it here. And there
+ are many shops who have a heritage of shell scripts. We have
+ expereince with all of these.</p>
+ </div>
+
+ <?php copyright ();?>
+</div>
+
+<script language="JavaScript" src="/JavaScript/Menus.js" type="text/javascript"></script>
+
+</body>
+</html>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+ <title>ClearSCM: Perl</title>
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Article.css">
+ <link rel="stylesheet" type="text/css" media="print" href="/css/Print.css">
+ <link rel="SHORTCUT ICON" href="http://clearscm.com/favicon.ico" type="image/png">
+ <?php
+ include "../php/clearscm.php";
+ menu_css ();
+ ?>
+</head>
+
+<body id="homepage">
+<?php heading ();?>
+
+<div id="page">
+ <div id="content">
+ <?php start_box ("cs4")?>
+ <h2>Perl</h2>
+ <?php end_box ();?>
+
+ <p>Perl is an extremely versitle language that is widely used. A
+ quick Perl script can be conjured up in a snap or you can utilize
+ an elaborate set of Perl Modules from <a href="http://cpan.org">CPAN</a>
+ or create your own modules, packages and objects. Perl supports many
+ advanced language concepts.</p>
+
+ <p>With any langauge there comes a style that is developed by users
+ of that lanaguage. Styles sometime vary widely - other times beginners
+ to the language have little if any. Over the years we have developed
+ our own <a href="PerlStyle.php">style</a>.</p>
+
+ <h3>Perl Modules</h3>
+
+ <p>Another thing we have developed is a set of modules of often used
+ functionality. Oh sure, there are tons of modules in CPAN, often more
+ comprehensive than ours. However such modules are written to cover each
+ and every aspect of their topic of focus, often including many constructs
+ and subroutines, parameters and the like as to make them more unweildy
+ and difficult to work with. Our modules are for "commonly used" things
+ to be used in a way so as to simply, not complicate, programming. Some of
+ the more basic modules are under GPL and available for download as <a
+ href="/clearlib.tar.gz">clearlib.tar.gz</a> and they are desribed here:</p>
+
+ <dl>
+ <dt><a href="../php/cvs_man.php?file=lib/CmdLine.pm">CmdLine.pm</a></dt>
+
+ <dd>Adds command history stack to command line oriented programs</dd>
+
+ <dt><a href="../php/cvs_man.php?file=lib/DateUtils.pm">DateUtils.pm</a></dt>
+
+ <dd>Simple date/time utilities</dd>
+
+ <dt><a href="/php/cvs_man.php?file=lib/Display.pm">Display.pm</a></dt>
+
+ <dd>Simple and consistant display routines for Perl</dd>
+
+ <dt><a href="/php/cvs_man.php?file=lib/GetConfig.pm">GetConfig.pm</a></dt>
+
+ <dd>Simple config file parsing</dd>
+
+ <dt><a href="/php/cvs_man.php?file=lib/Logger.pm">Logger.pm</a></dt>
+
+ <dd>Object oriented interface to handling logfiles</dd>
+
+ <dt><a href="/php/cvs_man.php?file=lib/Mail.pm">Mail.pm</a></dt>
+
+ <dd>A simplified approach to sending email</dd>
+
+ <dt><a href="/php/cvs_man.php?file=lib/OSDep.pm">OSDep.pm</a></dt>
+
+ <dd>Isolate OS dependencies</dd>
+
+ <dt><a href="/php/cvs_man.php?file=lib/Rexec.pm">Rexec.pm</a></dt>
+
+ <dd>Execute commands remotely</dd>
+
+ <dt><a href="/php/cvs_man.php?file=lib/TimeUtils.pm">TimeUtils.pm</a></dt>
+
+ <dd>Time utilities</dd>
+
+ <dt><a href="/php/cvs_man.php?file=lib/Utils.pm">Utils.pm</a></dt>
+
+ <dd>Simple and often used utilities</dd>
+ </dl>
+
+ <h3>Clearcase Perl Modules</h3>
+
+ <p>These modules are © ClearSCM, Inc. If you wish to use them then
+ please contact us.</p>
+
+ <dl>
+ <dt><a href="/php/cvs_man.php?file=lib/Clearcase.pm">Clearcase.pm</a></dt>
+
+ <dd>Object oriented interface to Clearcase</dd>
+
+ <dt><a href="/php/cvs_man.php?file=lib/Clearcase/Vobs.pm">Clearcase::Vobs.pm</a></dt>
+
+ <dd>Object oriented interface to Clearcase VOBs</dd>
+
+ <dt><a href="/php/cvs_man.php?file=lib/Clearcase/Vob.pm">Clearcase::Vob.pm</a></dt>
+
+ <dd>Object oriented interface to a Clearcase VOB</dd>
+
+ <dt><a href="/php/cvs_man.php?file=lib/Clearcase/Views.pm">Clearcase::Views.pm</a></dt>
+
+ <dd>Object oriented interface to Clearcase Views</dd>
+
+ <dt><a href="/php/cvs_man.php?file=lib/Clearcase/View.pm">Clearcase::View.pm</a></dt>
+
+ <dd>Object oriented interface to a Clearcase View</dd>
+
+ <dt><a href="/php/cvs_man.php?file=lib/Clearcase/Element.pm">Clearcase::Element.pm</a></dt>
+
+ <dd>Object oriented interface to a Clearcase Element</dd>
+
+ <dt><a href="/php/cvs_man.php?file=lib/Clearcase/UCM/Activity.pm">Clearcase::UCM::Activity.pm</a></dt>
+
+ <dd>Object oriented interface to a Clearcase UCM Activity</dd>
+
+ <dt><a href="/php/cvs_man.php?file=lib/Clearcase/UCM/Stream.pm">Clearcase::UCM::Stream.pm</a></dt>
+
+ <dd>Object oriented interface to a Clearcase UCM Stream</dd>
+ </dl>
+
+ <h3>Clearquest Perl Modules</h3>
+
+ <p>These modules are © ClearSCM, Inc. If you wish to use them then
+ please contact us.</p>
+
+ <dl>
+ <dt><a href="/php/cvs_man.php?file=lib/Clearquest.pm">Clearquest.pm</a></dt>
+
+ <dd>Object oriented interface to Clearquest</dd>
+
+ <dt><a href="/php/cvs_man.php?file=lib/Clearquest/Client.pm">Clearquest::Client.pm</a></dt>
+
+ <dd>Client interface to Clearquest Daemon</dd>
+
+ <dt><a href="/php/cvs_man.php?file=lib/Clearquest/DBService.pm">Clearquest::DBService.pm</a></dt>
+
+ <dd>Clearquest Database Service module</dd>
+
+ <dt><a href="/php/cvs_man.php?file=lib/Clearquest/LDAP.pm">Clearquest::LDAP.pm</a></dt>
+
+ <dd>Interface to LDAP info for Clearquest</dd>
+
+ <dt><a href="/php/cvs_man.php?file=lib/Clearquest/Server.pm">Clearquest::Server.pm</a></dt>
+
+ <dd>Clearquest Server Module</dd>
+ <dt><a href="/php/cvs_man.php?file=lib/Clearquest/REST.pm">Clearquest::REST.pm</a></dt>
+ <dd>Clearquest REST Module</dd>
+ </dl>
+ </div>
+
+ <?php copyright ();?>
+</div>
+
+<script language="JavaScript" src="/JavaScript/Menus.js" type="text/javascript"></script>
+
+</body>
+</html>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+
+ <title>ClearSCM: Services</title>
+
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/FrontPage.css">
+ <link rel="stylesheet" type="text/css" media="print" href="/css/Print.css">
+ <link rel="SHORTCUT ICON" href="http://clearscm.com/favicon.ico" type="image/png">
+
+ <!-- Google Analytics
+ <script src="http://www.google-analytics.com/urchin.js" type="text/javascript">
+ </script>
+ <script type="text/javascript">
+ _uacct = "UA-89317-1";
+ urchinTracker ();
+ </script>
+ Google Analytics -->
+
+ <?php
+ include "../php/clearscm.php";
+ menu_css ();
+ ?>
+</head>
+
+<body id="homepage" class="sm-r"> <!-- try r-sm, sm-r, ms-r or r-ms -->
+
+<?php heading ()?>
+
+<div id="page">
+ <div id="content">
+ <div id="contentWrapper2">
+ <div id="main">
+ <h2>Consultancy</h2>
+
+ <p>The core of our services lies in our people and their
+ expertise. Beyond our expertise, and perhaps because of it, we
+ are in a unique position to offer your company our unique
+ perspective based on years of experience.</p>
+
+ </div> <!-- main -->
+
+ <div id="supporting">
+ <?php start_box ("cs3");?>
+
+ <h2><a href="/services/consultancy.php">Consultancy</a></h2>
+
+ <p>Our core service is <a href="/people.php">our people</a>
+ and their years of experience in the field.</p>
+
+ <?php end_box ();?>
+
+ <?php start_box ("cs2");?>
+
+ <h2><a href="/services/custom_software.php">Custom Software
+ Solutions</a></h2>
+
+ <p>In addition to SCM, we build custom software solutions
+ using:</p>
+
+ <ul>
+ <li>Web Site Design</li>
+
+ <li>Web Application Design and Implementation</li>
+
+ <li>Custom Build Automation</li>
+
+ <li>Test Automation</li>
+ </ul>
+
+ <?php end_box ();?>
+
+ <?php start_box ("cs4");?>
+
+ <h2><a href="/services/sysadmin.php">Systems Administration</a></h2>
+
+ <p>Whether large or small, today's software is more
+ complex. Many resources are brought to bear to get your code
+ from inception to release....<a href="/sysadm">(more)</a>
+
+ <?php end_box ();?>
+
+ </div> <!-- supporting -->
+ </div> <!-- contentWrapper2 -->
+
+ <div id="contentWrapper1">
+ <div id="related">
+ <?php start_box ("cs2");?>
+
+ <h2><a href="/services/scm.php">SCM</a></h2>
+
+ <p>Managing the complexities of modern software requires
+ professional methodologies, professional tools and, well,
+ professionals. That's where we come in. We apply solid
+ configuration management practices to your software to
+ insure a smooth flow from design through deployment.</p>
+
+ <?php end_box ();?>
+
+ <?php start_box ("cs3");?>
+
+ <h2><a href="/services/web.php">Web Applications</a></h2>
+
+ <p>We also specialize in customer web applications to suit
+ your business needs</p>
+
+ <?php end_box ();?>
+
+ <?php start_box ("cs5");?>
+
+ <h2><a href="/services/customers.php">Customers</a></h2>
+
+ <p>We've worked with many, well known, fortune 500
+ companies. Let us work for you!</p>
+ <?php end_box ();?>
+ </div> <!-- related -->
+ </div> <!-- contentWrapper1 -->
+ </div> <!-- content -->
+ <?php copyright();?>
+</div> <!-- page -->
+
+<script language="JavaScript" src="/JavaScript/Menus.js" type="text/javascript"></script>
+
+</body>
+</html>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+
+ <title>ClearSCM: Services</title>
+
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/FrontPage.css">
+ <link rel="stylesheet" type="text/css" media="print" href="/css/Print.css">
+ <link rel="SHORTCUT ICON" href="http://clearscm.com/favicon.ico" type="image/png">
+
+ <!-- Google Analytics
+ <script src="http://www.google-analytics.com/urchin.js" type="text/javascript">
+ </script>
+ <script type="text/javascript">
+ _uacct = "UA-89317-1";
+ urchinTracker ();
+ </script>
+ Google Analytics -->
+
+ <?php
+ include "../php/clearscm.php";
+ menu_css ();
+ ?>
+</head>
+
+<body id="homepage" class="sm-r"> <!-- try r-sm, sm-r, ms-r or r-ms -->
+
+<?php heading ()?>
+
+<div id="page">
+ <div id="content">
+ <div id="contentWrapper2">
+ <div id="main">
+ <h2>Custom Software Solutions</h2>
+
+ <p>Rarely do companies live on SCM alone. There are many
+ internal and inhouse systems that grow up around Build and
+ Release Management systems including things like internal web
+ sites tracking nightly build processes. Integrations between
+ bug tracking systems and source control systems. Many times
+ such intergrations have yet to be made. As such we here at
+ ClearSCM also provide expertise in other, nontraditional SCM
+ roles such as:</p>
+
+ <ul>
+ <li>Web Site Design</li>
+
+ <li>Web Application Design and Implementation</li>
+
+ <li>Custom Build Automation</li>
+
+ <li>Test Automation</li>
+ </ul>
+
+ <p>Additionally, as any large group collaberative system such
+ as source control and build systems are, often we get involved
+ in other aspects of your corporate data processing systems
+ such as:</p>
+
+ <ul>
+ <li>Network Trouble Shooting</li>
+
+ <li>Licensing Monitoring</li>
+
+ <li>Systems Performance Monitoring</li>
+ </ul>
+
+ </div> <!-- main -->
+
+ <div id="supporting">
+ <?php start_box ("cs3");?>
+
+ <h2><a href="/services/consultancy.php">Consultancy</a></h2>
+
+ <p>Our core service is <a href="/people.php">our people</a>
+ and their years of experience in the field.</p>
+
+ <?php end_box ();?>
+
+ <?php start_box ("cs2");?>
+
+ <h2><a href="/services/custom_software.php">Custom Software
+ Solutions</a></h2>
+
+ <p>In addition to SCM, we build custom software solutions
+ using:</p>
+
+ <ul>
+ <li>Web Site Design</li>
+
+ <li>Web Application Design and Implementation</li>
+
+ <li>Custom Build Automation</li>
+
+ <li>Test Automation</li>
+ </ul>
+
+ <?php end_box ();?>
+
+ <?php start_box ("cs4");?>
+
+ <h2><a href="/services/sysadmin.php">Systems Administration</a></h2>
+
+ <p>Whether large or small, today's software is more
+ complex. Many resources are brought to bear to get your code
+ from inception to release....<a href="/sysadm">(more)</a>
+
+ <?php end_box ();?>
+
+ </div> <!-- supporting -->
+ </div> <!-- contentWrapper2 -->
+
+ <div id="contentWrapper1">
+ <div id="related">
+ <?php start_box ("cs2");?>
+
+ <h2><a href="/services/scm.php">SCM</a></h2>
+
+ <p>Managing the complexities of modern software requires
+ professional methodologies, professional tools and, well,
+ professionals. That's where we come in. We apply solid
+ configuration management practices to your software to
+ insure a smooth flow from design through deployment.</p>
+
+ <?php end_box ();?>
+
+ <?php start_box ("cs3");?>
+
+ <h2><a href="/services/web.php">Web Applications</a></h2>
+
+ <p>We also specialize in customer web applications to suit
+ your business needs</p>
+
+ <?php end_box ();?>
+
+ <?php start_box ("cs5");?>
+
+ <h2><a href="/services/customers.php">Customers</a></h2>
+
+ <p>We've worked with many, well known, fortune 500
+ companies. Let us work for you!</p>
+ <?php end_box ();?>
+ </div> <!-- related -->
+ </div> <!-- contentWrapper1 -->
+ </div> <!-- content -->
+ <?php copyright();?>
+</div> <!-- page -->
+
+<script language="JavaScript" src="/JavaScript/Menus.js" type="text/javascript"></script>
+
+</body>
+</html>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+
+ <title>ClearSCM: Services</title>
+
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/FrontPage.css">
+ <link rel="stylesheet" type="text/css" media="print" href="/css/Print.css">
+ <link rel="SHORTCUT ICON" href="http://clearscm.com/favicon.ico" type="image/png">
+
+ <!-- Google Analytics
+ <script src="http://www.google-analytics.com/urchin.js" type="text/javascript">
+ </script>
+ <script type="text/javascript">
+ _uacct = "UA-89317-1";
+ urchinTracker ();
+ </script>
+ Google Analytics -->
+
+ <?php
+ include "../php/clearscm.php";
+ menu_css ();
+ ?>
+</head>
+
+<body id="homepage" class="sm-r"> <!-- try r-sm, sm-r, ms-r or r-ms -->
+
+<?php heading ()?>
+
+<div id="page">
+ <div id="content">
+ <div id="contentWrapper2">
+ <div id="main">
+ <h2>Customers</h2>
+
+ <p>Some of our previous clients:</p>
+
+ <?php start_box ("cs3");?>
+ <table border=0>
+ <tbody>
+ <tr>
+ <td style="text-align:center">
+ <a href = "http://ameriquest.com/">
+ <img src = "/Logos/Ameriquest.gif"
+ alt = "Ameriquest Mortgage"
+ title = "Ameriquest Mortgage"
+ border = 0>
+ </a>
+ </td>
+ <td style="text-align:center">
+ <a href = "http://broadcom.com/">
+ <img src = "/Logos/Broadcom.gif"
+ alt = "Broadcom"
+ title = "Broadcom"
+ border = 0>
+ </a>
+ </td>
+ </tr>
+ <tr>
+ <td style="text-align:center">
+ <a href = "http://cisco.com/">
+ <img src = "/Logos/Cisco.gif"
+ alt = "Cisco Systems"
+ title = "Cisco Systems"
+ border = 0>
+ </a>
+ </td>
+ <td style="text-align:center">
+ <a href = "http://hp.com/">
+ <img src = "/Logos/HPLogo.gif"
+ alt = "Hewlett Packard"
+ title = "Hewlett Packard"
+ border = 0>
+ </a>
+ </td>
+ </tr>
+ <tr>
+ <td style="text-align:center">
+ <a href = "http://lynuxworks.com/">
+ <img src = "/Logos/LynuxWorks.gif"
+ alt = "LynuxWorks"
+ title = "LynuxWorks"
+ border = 0>
+ </a>
+ </td>
+ <td style="text-align:center">
+ <a href = "http://salira.com/">
+ <img src = "/Logos/Salira.gif"
+ alt = "Salira Optical Network Systems"
+ title = "Salira Optical Network Systems"
+ border = 0>
+ </a>
+ </td>
+ </tr>
+ <tr>
+ <td style="text-align:center">
+ <a href = "http://sun.com/">
+ <img src = "/Logos/Sun.jpg"
+ alt = "Sun Microsystems"
+ title = "Sun Microsystems"
+ border = 0>
+ </a>
+ </td>
+ <td style="text-align:center">
+ <a href = "http://ti.com/">
+ <img src = "/Logos/TexasInstruments.jpg"
+ alt = "Texas Instruments"
+ title = "Texas Instruments"
+ border = 0>
+ </a>
+ </td>
+ </tr>
+ </tbody>
+ </table>
+ <?php end_box ();?>
+
+ <p>We'd love to make you our next client.</p>
+
+ </div> <!-- main -->
+
+ <div id="supporting">
+ <?php start_box ("cs3");?>
+
+ <h2><a href="/services/consultancy.php">Consultancy</a></h2>
+
+ <p>Our core service is <a href="/people.php">our people</a>
+ and their years of experience in the field.</p>
+
+ <?php end_box ();?>
+
+ <?php start_box ("cs2");?>
+
+ <h2><a href="/services/custom_software.php">Custom Software
+ Solutions</a></h2>
+
+ <p>In addition to SCM, we build custom software solutions
+ using:</p>
+
+ <ul>
+ <li>Web Site Design</li>
+
+ <li>Web Application Design and Implementation</li>
+
+ <li>Custom Build Automation</li>
+
+ <li>Test Automation</li>
+ </ul>
+
+ <?php end_box ();?>
+
+ <?php start_box ("cs4");?>
+
+ <h2><a href="/services/sysadmin.php">Systems Administration</a></h2>
+
+ <p>Whether large or small, today's software is more
+ complex. Many resources are brought to bear to get your code
+ from inception to release....<a href="/sysadm">(more)</a>
+
+ <?php end_box ();?>
+
+ </div> <!-- supporting -->
+ </div> <!-- contentWrapper2 -->
+
+ <div id="contentWrapper1">
+ <div id="related">
+ <?php start_box ("cs2");?>
+
+ <h2><a href="/services/scm.php">SCM</a></h2>
+
+ <p>Managing the complexities of modern software requires
+ professional methodologies, professional tools and, well,
+ professionals. That's where we come in. We apply solid
+ configuration management practices to your software to
+ insure a smooth flow from design through deployment.</p>
+
+ <?php end_box ();?>
+
+ <?php start_box ("cs3");?>
+
+ <h2><a href="/services/web.php">Web Applications</a></h2>
+
+ <p>We also specialize in customer web applications to suit
+ your business needs</p>
+
+ <?php end_box ();?>
+
+ <?php start_box ("cs5");?>
+
+ <h2><a href="/services/customers.php">Customers</a></h2>
+
+ <p>We've worked with many, well known, fortune 500
+ companies. Let us work for you!</p>
+ <?php end_box ();?>
+ </div> <!-- related -->
+ </div> <!-- contentWrapper1 -->
+ </div> <!-- content -->
+ <?php copyright();?>
+</div> <!-- page -->
+
+<script language="JavaScript" src="/JavaScript/Menus.js" type="text/javascript"></script>
+
+</body>
+</html>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+
+ <title>ClearSCM: Services</title>
+
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/FrontPage.css">
+ <link rel="stylesheet" type="text/css" media="print" href="/css/Print.css">
+ <link rel="SHORTCUT ICON" href="http://clearscm.com/favicon.ico" type="image/png">
+
+ <!-- Google Analytics
+ <script src="http://www.google-analytics.com/urchin.js" type="text/javascript">
+ </script>
+ <script type="text/javascript">
+ _uacct = "UA-89317-1";
+ urchinTracker ();
+ </script>
+ Google Analytics -->
+
+ <?php
+ include "../php/clearscm.php";
+ menu_css ();
+ ?>
+</head>
+
+<body id="homepage" class="sm-r"> <!-- try r-sm, sm-r, ms-r or r-ms -->
+
+<?php heading ()?>
+
+<div id="page">
+ <div id="content">
+ <div id="contentWrapper2">
+ <div id="main">
+ <h2>ClearSCM Services</h2>
+
+ <p>We offer the following services.</p>
+
+ </div> <!-- main -->
+
+ <div id="supporting">
+ <?php start_box ("cs3");?>
+
+ <h2><a href="/services/consultancy.php">Consultancy</a></h2>
+
+ <p>Our core service is <a href="/people.php">our people</a>
+ and their years of experience in the field.</p>
+
+ <?php end_box ();?>
+
+ <?php start_box ("cs2");?>
+
+ <h2><a href="/services/custom_software.php">Custom Software
+ Solutions</a></h2>
+
+ <p>In addition to SCM, we build custom software solutions
+ using:</p>
+
+ <ul>
+ <li>Web Site Design</li>
+
+ <li>Web Application Design and Implementation</li>
+
+ <li>Custom Build Automation</li>
+
+ <li>Test Automation</li>
+ </ul>
+
+ <?php end_box ();?>
+
+ <?php start_box ("cs4");?>
+
+ <h2><a href="/services/sysadmin.php">Systems Administration</a></h2>
+
+ <p>Whether large or small, today's software is more
+ complex. Many resources are brought to bear to get your code
+ from inception to release....<a href="/sysadm">(more)</a>
+
+ <?php end_box ();?>
+
+ </div> <!-- supporting -->
+ </div> <!-- contentWrapper2 -->
+
+ <div id="contentWrapper1">
+ <div id="related">
+ <?php start_box ("cs2");?>
+
+ <h2><a href="/services/scm.php">SCM</a></h2>
+
+ <p>Managing the complexities of modern software requires
+ professional methodologies, professional tools and, well,
+ professionals. That's where we come in. We apply solid
+ configuration management practices to your software to
+ insure a smooth flow from design through deployment.</p>
+
+ <?php end_box ();?>
+
+ <?php start_box ("cs3");?>
+
+ <h2><a href="/services/web.php">Web Applications</a></h2>
+
+ <p>We also specialize in customer web applications to suit
+ your business needs</p>
+
+ <?php end_box ();?>
+
+ <?php start_box ("cs5");?>
+
+ <h2><a href="/services/customers.php">Customers</a></h2>
+
+ <p>We've worked with many, well known, fortune 500
+ companies. Let us work for you!</p>
+ <?php end_box ();?>
+ </div> <!-- related -->
+ </div> <!-- contentWrapper1 -->
+ </div> <!-- content -->
+ <?php copyright();?>
+</div> <!-- page -->
+
+<script language="JavaScript" src="/JavaScript/Menus.js" type="text/javascript"></script>
+
+</body>
+</html>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+
+ <title>ClearSCM: Services</title>
+
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/FrontPage.css">
+ <link rel="stylesheet" type="text/css" media="print" href="/css/Print.css">
+ <link rel="SHORTCUT ICON" href="http://clearscm.com/favicon.ico" type="image/png">
+
+ <!-- Google Analytics
+ <script src="http://www.google-analytics.com/urchin.js" type="text/javascript">
+ </script>
+ <script type="text/javascript">
+ _uacct = "UA-89317-1";
+ urchinTracker ();
+ </script>
+ Google Analytics -->
+
+ <?php
+ include "../php/clearscm.php";
+ menu_css ();
+ ?>
+</head>
+
+<body id="homepage" class="sm-r"> <!-- try r-sm, sm-r, ms-r or r-ms -->
+
+<?php heading ()?>
+
+<div id="page">
+ <div id="content">
+ <div id="contentWrapper2">
+ <div id="main">
+ <h2>Source Configuration Management</h2>
+
+ <p>Managing the complexities of modern software requires
+ professional methodologies, professional tools and, well,
+ professionals. That's where we come in. We apply solid
+ configuration management practices to your software to insure
+ a smooth flow from design through deployment.</p>
+
+ </div> <!-- main -->
+
+ <div id="supporting">
+ <?php start_box ("cs3");?>
+
+ <h2><a href="/services/consultancy.php">Consultancy</a></h2>
+
+ <p>Our core service is <a href="/people.php">our people</a>
+ and their years of experience in the field.</p>
+
+ <?php end_box ();?>
+
+ <?php start_box ("cs2");?>
+
+ <h2><a href="/services/custom_software.php">Custom Software
+ Solutions</a></h2>
+
+ <p>In addition to SCM, we build custom software solutions
+ using:</p>
+
+ <ul>
+ <li>Web Site Design</li>
+
+ <li>Web Application Design and Implementation</li>
+
+ <li>Custom Build Automation</li>
+
+ <li>Test Automation</li>
+ </ul>
+
+ <?php end_box ();?>
+
+ <?php start_box ("cs4");?>
+
+ <h2><a href="/services/sysadmin.php">Systems Administration</a></h2>
+
+ <p>Whether large or small, today's software is more
+ complex. Many resources are brought to bear to get your code
+ from inception to release....<a href="/sysadm">(more)</a>
+
+ <?php end_box ();?>
+
+ </div> <!-- supporting -->
+ </div> <!-- contentWrapper2 -->
+
+ <div id="contentWrapper1">
+ <div id="related">
+ <?php start_box ("cs2");?>
+
+ <h2><a href="/services/scm.php">SCM</a></h2>
+
+ <p>Managing the complexities of modern software requires
+ professional methodologies, professional tools and, well,
+ professionals. That's where we come in. We apply solid
+ configuration management practices to your software to
+ insure a smooth flow from design through deployment.</p>
+
+ <?php end_box ();?>
+
+ <?php start_box ("cs3");?>
+
+ <h2><a href="/services/web.php">Web Applications</a></h2>
+
+ <p>We also specialize in customer web applications to suit
+ your business needs</p>
+
+ <?php end_box ();?>
+
+ <?php start_box ("cs5");?>
+
+ <h2><a href="/services/customers.php">Customers</a></h2>
+
+ <p>We've worked with many, well known, fortune 500
+ companies. Let us work for you!</p>
+ <?php end_box ();?>
+ </div> <!-- related -->
+ </div> <!-- contentWrapper1 -->
+ </div> <!-- content -->
+ <?php copyright();?>
+</div> <!-- page -->
+
+<script language="JavaScript" src="/JavaScript/Menus.js" type="text/javascript"></script>
+
+</body>
+</html>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+
+ <title>ClearSCM: Services</title>
+
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/FrontPage.css">
+ <link rel="stylesheet" type="text/css" media="print" href="/css/Print.css">
+ <link rel="SHORTCUT ICON" href="http://clearscm.com/favicon.ico" type="image/png">
+
+ <!-- Google Analytics
+ <script src="http://www.google-analytics.com/urchin.js" type="text/javascript">
+ </script>
+ <script type="text/javascript">
+ _uacct = "UA-89317-1";
+ urchinTracker ();
+ </script>
+ Google Analytics -->
+
+ <?php
+ include "../php/clearscm.php";
+ menu_css ();
+ ?>
+</head>
+
+<body id="homepage" class="sm-r"> <!-- try r-sm, sm-r, ms-r or r-ms -->
+
+<?php heading ()?>
+
+<div id="page">
+ <div id="content">
+ <div id="contentWrapper2">
+ <div id="main">
+ <h2>Systems Administration</h2>
+
+ </p>Whether large or small, today's software is more
+ complex. Many resources are brought to bear to get your code
+ from inception to release. As such many different machines,
+ architectures and operating systems need to be tamed to work
+ in tandem with each other for smooth operations. Thus the SCM
+ professional needs to be well versed in Systems
+ Administrations of these resources.</p>
+
+ </div> <!-- main -->
+
+ <div id="supporting">
+ <?php start_box ("cs3");?>
+
+ <h2><a href="/services/consultancy.php">Consultancy</a></h2>
+
+ <p>Our core service is <a href="/people.php">our people</a>
+ and their years of experience in the field.</p>
+
+ <?php end_box ();?>
+
+ <?php start_box ("cs2");?>
+
+ <h2><a href="/services/custom_software.php">Custom Software
+ Solutions</a></h2>
+
+ <p>In addition to SCM, we build custom software solutions
+ using:</p>
+
+ <ul>
+ <li>Web Site Design</li>
+
+ <li>Web Application Design and Implementation</li>
+
+ <li>Custom Build Automation</li>
+
+ <li>Test Automation</li>
+ </ul>
+
+ <?php end_box ();?>
+
+ <?php start_box ("cs4");?>
+
+ <h2><a href="/services/sysadmin.php">Systems Administration</a></h2>
+
+ <p>Whether large or small, today's software is more
+ complex. Many resources are brought to bear to get your code
+ from inception to release....<a href="/sysadm">(more)</a>
+
+ <?php end_box ();?>
+
+ </div> <!-- supporting -->
+ </div> <!-- contentWrapper2 -->
+
+ <div id="contentWrapper1">
+ <div id="related">
+ <?php start_box ("cs2");?>
+
+ <h2><a href="/services/scm.php">SCM</a></h2>
+
+ <p>Managing the complexities of modern software requires
+ professional methodologies, professional tools and, well,
+ professionals. That's where we come in. We apply solid
+ configuration management practices to your software to
+ insure a smooth flow from design through deployment.</p>
+
+ <?php end_box ();?>
+
+ <?php start_box ("cs3");?>
+
+ <h2><a href="/services/web.php">Web Applications</a></h2>
+
+ <p>We also specialize in customer web applications to suit
+ your business needs</p>
+
+ <?php end_box ();?>
+
+ <?php start_box ("cs5");?>
+
+ <h2><a href="/services/customers.php">Customers</a></h2>
+
+ <p>We've worked with many, well known, fortune 500
+ companies. Let us work for you!</p>
+ <?php end_box ();?>
+ </div> <!-- related -->
+ </div> <!-- contentWrapper1 -->
+ </div> <!-- content -->
+ <?php copyright();?>
+</div> <!-- page -->
+
+<script language="JavaScript" src="/JavaScript/Menus.js" type="text/javascript"></script>
+
+</body>
+</html>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+
+ <title>ClearSCM: Services</title>
+
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/FrontPage.css">
+ <link rel="stylesheet" type="text/css" media="print" href="/css/Print.css">
+ <link rel="SHORTCUT ICON" href="http://clearscm.com/favicon.ico" type="image/png">
+
+ <!-- Google Analytics
+ <script src="http://www.google-analytics.com/urchin.js" type="text/javascript">
+ </script>
+ <script type="text/javascript">
+ _uacct = "UA-89317-1";
+ urchinTracker ();
+ </script>
+ Google Analytics -->
+
+ <?php
+ include "../php/clearscm.php";
+ menu_css ();
+ ?>
+</head>
+
+<body id="homepage" class="sm-r"> <!-- try r-sm, sm-r, ms-r or r-ms -->
+
+<?php heading ()?>
+
+<div id="page">
+ <div id="content">
+ <div id="contentWrapper2">
+ <div id="main">
+ <h2>Web Applications</h2>
+
+ <p>It's hard to imagine utilizing computers today without
+ using a browser. Sure we all <i>surf the web</i> with our
+ browers. But increasingly internal processes are presented and
+ managed via <i>web applications</i>. Some of these web
+ applications are produced by 3rd partys such as IBM Rational's
+ Clearcase web or Clearquest web, to monitoring web
+ applications that show us the state of our servers and
+ networks to home grown applications that give us vital
+ information about our internal processes. ClearSCM people can
+ deal with all of them.</p>
+
+ </div> <!-- main -->
+
+ <div id="supporting">
+ <?php start_box ("cs3");?>
+
+ <h2><a href="/services/consultancy.php">Consultancy</a></h2>
+
+ <p>Our core service is <a href="/people.php">our people</a>
+ and their years of experience in the field.</p>
+
+ <?php end_box ();?>
+
+ <?php start_box ("cs2");?>
+
+ <h2><a href="/services/custom_software.php">Custom Software
+ Solutions</a></h2>
+
+ <p>In addition to SCM, we build custom software solutions
+ using:</p>
+
+ <ul>
+ <li>Web Site Design</li>
+
+ <li>Web Application Design and Implementation</li>
+
+ <li>Custom Build Automation</li>
+
+ <li>Test Automation</li>
+ </ul>
+
+ <?php end_box ();?>
+
+ <?php start_box ("cs4");?>
+
+ <h2><a href="/services/sysadmin.php">Systems Administration</a></h2>
+
+ <p>Whether large or small, today's software is more
+ complex. Many resources are brought to bear to get your code
+ from inception to release....<a href="/sysadm">(more)</a>
+
+ <?php end_box ();?>
+
+ </div> <!-- supporting -->
+ </div> <!-- contentWrapper2 -->
+
+ <div id="contentWrapper1">
+ <div id="related">
+ <?php start_box ("cs2");?>
+
+ <h2><a href="/services/scm.php">SCM</a></h2>
+
+ <p>Managing the complexities of modern software requires
+ professional methodologies, professional tools and, well,
+ professionals. That's where we come in. We apply solid
+ configuration management practices to your software to
+ insure a smooth flow from design through deployment.</p>
+
+ <?php end_box ();?>
+
+ <?php start_box ("cs3");?>
+
+ <h2><a href="/services/web.php">Web Applications</a></h2>
+
+ <p>We also specialize in customer web applications to suit
+ your business needs</p>
+
+ <?php end_box ();?>
+
+ <?php start_box ("cs5");?>
+
+ <h2><a href="/services/customers.php">Customers</a></h2>
+
+ <p>We've worked with many, well known, fortune 500
+ companies. Let us work for you!</p>
+ <?php end_box ();?>
+ </div> <!-- related -->
+ </div> <!-- contentWrapper1 -->
+ </div> <!-- content -->
+ <?php copyright();?>
+</div> <!-- page -->
+
+<script language="JavaScript" src="/JavaScript/Menus.js" type="text/javascript"></script>
+
+</body>
+</html>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+
+ <title>ClearSCM: Environment</title>
+
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Article.css">
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Code.css">
+ <link rel="stylesheet" type="text/css" media="print" href="/css/Print.css">
+ <link rel="SHORTCUT ICON" href="http://clearscm.com/favicon.ico" type="image/png">
+
+ <!-- Google Analytics
+ <script src="http://www.google-analytics.com/urchin.js" type="text/javascript">
+ </script>
+ <script type="text/javascript">
+ _uacct = "UA-89317-1";
+ urchinTracker ();
+ </script>
+ Google Analytics -->
+
+ <?php
+ include "php/clearscm.php";
+ menu_css ();
+ ?>
+</head>
+
+<body>
+
+<?php heading ();?>
+
+<div id="page">
+ <div id="content">
+
+<h2>Your Environment Can Make or Break You</h2>
+
+<p>It's often no wonder that mere morals shudder at the site of a
+command prompt and scream bloody murder when asked to drop into the
+command line. It's a baren and unfamilar place for most people filled
+with all the potential pitfalls of actually getting work done! But it
+doesn't have to be that way.</p>
+
+<p>Indeed the basic shell presented by Unix, and Windows for that
+matter, is pretty bleak, harsh and forboding configured with default
+settings. But shells and shell languages are wonderfully configureable
+and customizable as well as extremely powerful. Often error messages
+come out in command line executions that are never caught by the GUIs
+and displayed. And you can often get and manipulate a lot of
+information given the rich set of commands and piping techniques
+afforded by most modern shells. Nevermind you can easily set up quick
+loops to itterate through the information in ways that will quite
+frankly dazzle your friends... well your geek friends at least.</p>
+
+<p>All that said this document is to describe a set of start up
+scripts that I've developed over the years that I find extremely
+useful. The environment is easily installable yet quite sophisticated
+at the same time.</p>
+
+<blockquote><b>Note:</b> For Windows I use Cygwin as it provides a
+full, Linux like environment such that most stuff runs the same on
+Unix, FreeBSD, Solaris, Linux and Windows without change. There are
+additional <a href="#Cygwin Tweaks">Cygwin Tweaks</a> to be described
+later that make the Windows environment further normalized and make
+productived.</blockquote>
+
+<h3>The Package</h3>
+
+<p>For quite some time now I have packaged up my stuff to reside under
+~/.rc. This allows me to easily grep for the occurances of things in
+one convienent place. I've even places my XEmacs customizations under
+~/.rc too. All of this is in CVS on my corporate site and I keep
+things up to date and documented there. You can obtain the package as
+a tarball <a href="/clearenv.tar.gz">clearenv.tar.gz</a>. Unpack the
+tar image and simply run ~/.rc/setup_rc:</p>
+
+<div class="code">$ cd ~
+$ tar -zxf rc.tar.gz
+$ .rc/setup_rc
+$
+</div>
+
+<h3>History</h3>
+
+<p>Full version history can be viewed <a
+href="http://clearscm.com/viewvc/clearscm.com/rc/">here</a>.</p>
+
+<p>I now have separated out client customizations, i.e. startup
+functionality particular to different clients or employers, into the
+~/.rc/client_scripts directory. The start up scripts will source all
+executable scripts under that directory.</p>
+
+<p>A set of Clearcase functions exist under ~/.rc/clearcase and a set
+of Multisite scripts under ~/.rc/multisite. By and large these serve
+to set up the Clearcase environment and mostly change common Clearcase
+commands from cleartool lsview to simply lsview. Where appropriate
+additional functionality has been added such as lsview <part of
+view name> which effectively does a cleartool lsview piped to grep
+to find views with <part of view name> in their names. An lsview
+by itself will do cleartool lsview piped to your $PAGER and lsviews
+will generate a list of views useful in constructs such as:</p>
+
+<div class="code">$ for view in $(lsviews); do
+> echo "Processing view $view"
+> # Do some thing with $view
+> done
+</div>
+
+<p>Other functions are provided like cm (an alias for cleartool -
+stands for configuration management), cdiff (do a clearcase diff),
+clist (list all checkouts), etc. Note this has been named cm because
+I'm starting to integrate other CM systems such as CVS. So a cdiff
+does a cleartool diff if we are on a machine that has Clearcase
+whereas if we are in a diretory that has a CVS directory a cvs diff
+will be done instead. Similarly clist works for both CM systems
+too. Further development of this is ongoing.</p>
+
+<p>Finally there are some environment variables that are available for
+handy reference such as $RGY which points to where the Clearcase
+registry files are, etc.</p>
+
+<h3>Functions</h3>
+
+<p>Most shell functions are defined in ~/.rc/functions. Most of these
+functions deal with setting it up such that the title bar of the
+terminal contains an indication of whether or not you are in a view or
+a cvs work area, what portion of the vob or directory you are
+currently in and whether or not you are root (called Wizard). These
+functions seek to maintain the proper titlebar such that if you say
+ssh'ed to another machine the titlebar would change - if you exit that
+ssh session the titlebar should change back.</p>
+
+<p>Another handy function is sj - stands for Show Job. It's basically
+a ps -ef | grep -i <str&gr;. How many times to do you that? Why not
+make it shorter? There is also user and group functions which
+essentially do ypcat [passwd|group] | grep -i <str>. This allows
+you to easily search the passwd and group NIS maps (Note I have not
+implemented this for Windows yet but the thought would be to make it
+function the same).</p>
+
+<h3>bash_login</h3>
+
+<p>This whole start up environment is oriented for the bash(1)
+shell. It used to be ksh(1) but I've moved on to bash. As such the
+~/.rc/base_login is where most stuff gets sourced and set up. It also
+mitigates some of the differences between the various supported OSes
+as well as sets up aliases, etc.</p>
+
+<h3>set_path</h3>
+
+<p>This script sets up the PATH from scratch. The idea was if your
+PATH ever gets hosed you can get it all back with
+~/.rc/set_path. There is a list of paths to places where applications
+may or may not exist. These are fed into a function that appends to
+the PATH variable but only if the directory actually exists. So while
+you might see /usr/local/mysql/bin but not have mysql installed, the
+append_to_path function will recognize that /usr/local/mysql/bin does
+not exist and not append it to the path.</p>
+
+<a name="Cygwin Tweaks"></a><h3>Cygwin Tweaks</h3>
+
+<p>In order to help out the start up scripts I mount the Clearcase
+view drive (by default M) to /view. Now /view/<viewname> is the
+same between Unix and Cygwin. Also I mount C:\Program Files ->
+/apps. Just makes more sense and is easier to type.</p>
+
+<h2>Clearcase Functions</h2>
+
+<h3>General function - scm = cleartool</h3>
+
+<p>The scm function calls cleartool (and possibly cvs). It also gets
+rid of the problem with Clearcase under Windows sending extra carriage
+returns. If you wish to do a Clearcase cleartool command and it is not
+short circuted then you can use scm instead. Short circuted commands
+are basically cleartool command that you don't need to even specify scm
+for. Examples include lsview, lsstream, pwv, etc.</p>
+
+<p><b>Note:</b> The ct command has been aliased to the scm command.</p>
+
+<p>Clearcase commands, using either the scm function of the familiar scm
+function, also provide full command line completion! This means that if
+you do scm lsview ad and then type tab, bash will complete your ad string
+to expand to all of the views that start with the letters "ad". In other
+words, bash completion for Clearcase commands means that hitting tab
+in scm commands will complete the command line much like file name
+completion currently works in bash, except it's smart in that if the
+context of the scm command calls for a view name here then bash
+completes view names. If the context of a scm command calls for a vob name
+then completion will complete vob names, or baselines or labels, etc.
+Even options are completed (type scm lsview - then tab) or even command
+names themselves (type scm <space> then tab twice and you'll be
+given a list of all Clearcase commands!</p>
+
+<h3>ci</h3>
+
+<p>The ci short circut stands for check in. This will use your
+~/.clearcase_profile to specify the -nc if that is your default. So
+then the common action of check in goes from cleartool checkin ->
+ci</p>
+
+<h3>co</h3>
+
+<p>Same as ci but stands for checkout.</p>
+
+<h3>unco</h3>
+
+<p>Undo checkout</p>
+
+<h3>Setview</h3>
+
+<p>This is the regular setview command for Unix. Setview is not
+supported under Windows but we fake it by doing a startview then
+mounting /view/<viewname> to /vobs and start a new bash
+shell. We are attempting to emulate the setview of Unix but we can't
+fully because in Unix you are chrooted and /view is what is called a
+<i>super root</i>. when we exit the setview under Windows we then
+umount /vobs. The problem here is that we can only have one view set
+on the system because the /vobs mount point contains that view's
+name. So if terminal 1 setview view1 and terminal 2 setview view2,
+terminal 1 would see things as of the last mount of /vob which is
+view2. Further if either terminal exists the mount is unmounted and
+the other terminal now has no current working directory. This is a
+known bug and... I'm working on it!</p>
+
+<h3>startview</h3>
+
+<p>Stgarts a view then cd's the /view/<viewname></p>
+
+<h3>endview</h3>
+
+<p>Does cm endview</p>
+
+<h3>killview</h3>
+
+<p>Does endview with -server</p>
+
+<h3>mkview</h3>
+
+<p>Short circut of cm mkview</p>
+
+<h3>makeview (experimental)</h3>
+
+<p>Attempts to create or reuse a view. It takes one parameter - the
+stream. The stream you say? Yes! This is UCM. It takes the stream name
+and attempts create a view on that stream. First it checks to see if
+that view has already been made and if so it does a setview. If not it
+attempts to make the view. If it's unsuccessful it tries to do an
+lsstream by first lopping off a few characters of the stream name and
+searching for that hoping that the stream name you provided was
+"close".</p>
+
+<p><b>Note:</b> The view tag composed will be ${USER}_$STREAM.</p>
+
+<h3>rmview</h3>
+
+<p>Short circut for cm rmview</p>
+
+<h3>lsview</h3>
+
+<p>Lists views. If no parameters are given then it does an cm lsview
+-short | $PAGER. This lists all viewnames and pages it. If you give it
+one parameter then it pipes the output to grep, grepping for that
+string case insensitive. If you give it more parameters it just short
+circuts to cm lsview <parms>.</p>
+
+<h3>myviews</h3>
+
+<p>Lists views that have $USER in them assuming they are UCM oriented
+and getting the headline of UCM activity set in the view, if any. Note
+that this is a little slow to talk to UCM to get the headlines. If you
+just want to see what views are yours (i.e. have your userid in their
+names) then do lsview $USER.</p>
+
+<h3>llview</h3>
+
+<p>One of the "ll" commands. When you see ll think "list long". This
+does a cm lsview -l.</p>
+
+<h3>lsviews</h3>
+
+<p>Easy way to get a list of all views (remember lsview by itself will
+use $PAGER). Useful for loops.</p>
+
+<h3>lsvob</h3>
+
+<p>Short circut for cm lsvob. Functions like lsview (pages, searches, etc).
+
+<h3>llvob</h3>
+
+<p>Long vob listing</p>
+
+<h3>setcs</h3>
+
+<p>Short circut for cm setsc</p>
+
+<h3>edcs</h3>
+
+<p>Short circut for cm edsc</p>
+
+<h3>catcs</h3>
+
+<p>Short circut for cm catsc</p>
+
+<h3>pwv</h3>
+
+<p>Prints the current view (-short)</p>
+
+<h3>rmtag</h3>
+
+<p>Short circut for cm rmtag</p>
+
+<h3>mktag</h3>
+
+<p>Short circut for cm mktag</p>
+
+<h3>describe</h3>
+
+<p>Short circut for cm describe</p>
+
+<h3>vtree</h3>
+
+<p>Display version tree (cm lsvtree -g)</p>
+
+<h3>merge</h3>
+
+<p>Short circut for cm merge</p>
+
+<h3>cdiff</h3>
+
+<p>Performs graphical diff for Clearcase or with two non-Clearcase
+files or does a cvs diff if in CVS mode.</p>
+
+<h3>space</h3>
+
+<p>Short circut of cm space</p>
+
+<h3>register</h3>
+
+<p>Short circut of cm register</p>
+
+<h3>unregister</h3>
+
+<p>Short circut of cm unregister</p>
+
+<h3>hostinfo</h3>
+
+<p>Short circut of cm hostinfo</p>
+
+<h3>lstrig</h3>
+
+<p>Lists the trigger type if two parms are given (trtype and pvob)
+otherwise alias for cm lstype -kind trtype | $PAGER.</p>
+
+<h3>lltrig</h3>
+
+<p>Lists long the trigger type if two parms are given (trtype and pvob)
+otherwise alias for cm lstype -long -kind trtype | $PAGER.</p>
+
+<h3>lsbr</h3>
+
+<p>Lists lbtype's</p>
+
+<h3>lsstream</h3>
+
+<p>Lists all streams to $PAGER to alias for cm lsstream if parameters
+are specified.</p>
+
+<h3>llstream</h3>
+
+<p>Lists long all streams to $PAGER to alias for cm lsstream -lif
+parameters are specified.</p>
+
+<h3>rebase</h3>
+
+<p>Short circut for cm rebase.</p>
+
+<h3>deliver</h3>
+
+<p>Short circut for cm deliver.</p>
+
+<h3>lsbl</h3>
+
+<p>Short circut for cm lsbl.</p>
+
+<h3>lsproject</h3>
+
+<p>Lists all projects to your $PAGER or alias for cm lsproject.</p>
+
+<h3>llproject</h3>
+
+<p>Lists long all projects to your $PAGER or alias for cm lsproject -long.</p>
+
+<h3>lsstgloc</h3>
+
+<p>Lists all stglocs to your $PAGER or alias for cm lsstgloc.</p>
+
+<h3>llstgloc</h3>
+
+<p>Lists long all stglocs to your $PAGER or alias for cm lsstgloc -long.</p>
+
+<h3>lsstream</h3>
+
+<p>Lists all streams to your $PAGER or alias for cm lsstream.</p>
+
+<h3>llstream</h3>
+
+<p>Lists long all streams to your $PAGER or alias for cm lsstream -long.</p>
+
+<h3>lsact</h3>
+
+<p>Lists all activities to your $PAGER or alias for cm lsactivity.</p>
+
+<h3>llact</h3>
+
+<p>Lists long all activities to your $PAGER or alias for cm lsactivity -long.</p>
+
+<h3>setact</h3>
+
+<p>Short circut for cm setactivity</p>
+
+<h3>clist</h3>
+
+<p>Lists all currently checked out elements or locally modified cvs entries.</p>
+
+<h3>ciwork</h3>
+
+<p>Check in all checked out work.</p>
+ </div> <!-- content -->
+
+ <?php copyright ();?>
+</div>
+
+<script language="JavaScript" src="/JavaScript/Menus.js" type="text/javascript"></script>
+
+</body>
+</html>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
+ <meta name="GENERATOR" content="Mozilla/4.61 [en] (Win98; U) [Netscape]">
+
+ <title>ClearSCM: Systems Administration</title>
+
+ <link rel="stylesheet" type="text/css" media="screen" href="/css/Article.css">
+ <link rel="stylesheet" type="text/css" media="print" href="/css/Print.css">
+ <link rel="SHORTCUT ICON" href="http://clearscm.com/favicon.ico" type="image/png">
+
+ <!-- Google Analytics
+ <script src="http://www.google-analytics.com/urchin.js" type="text/javascript">
+ </script>
+ <script type="text/javascript">
+ _uacct = "UA-89317-1";
+ urchinTracker ();
+ </script>
+ Google Analytics -->
+
+ <?php
+ include "../php/clearscm.php";
+ menu_css ();
+ ?>
+</head>
+
+<body id="homepage">
+<?php heading ();?>
+
+<div id="page">
+ <div id="content">
+ <?php start_box ("cs4")?>
+ <h2>Systems Administration</h2>
+ <?php end_box ();?>
+
+ <p>Whether large or small, today's software is more complex. Many
+ resources are brought to bear to get your code from inception to
+ release. As such many different machines, architectures and
+ operating systems need to be tamed to work in tandem with each
+ other for smooth operations. Thus the SCM professional needs to be
+ well versed in Systems Administrations of these resources.</p>
+
+ <p>Our people have many years of Systems Administration experience
+ in Windows, Unix and Linux Operating Systems. Additionally we have
+ been at many clients so we have seen how shops administer their
+ machines from various perspectives. So instead of having 10 years
+ of systems administration experinece in one company, thus knowing
+ only how they manage their systems, we have years of experience at
+ many companies which helps us understand the many ways of
+ administrating systems, some good and some not so good.</p>
+ </div>
+
+ <?php copyright ();?>
+</div>
+
+<script language="JavaScript" src="/JavaScript/Menus.js" type="text/javascript"></script>
+
+</body>
+</html>
projects / clearscm.git / commitdiff
