#!/usr/bin/perl -w
# avoid shell starter method here - otherwise we cannot kill the daemon
use 5.008;      ## minimum perl version
use strict;
use threads;    ## REMOVE FOR UNTHREADED PERL
use Getopt::Std qw( getopts );
use POSIX qw( );
import License;
import GridEngine;
import Qconf;

my ($releaseDate) = qw( 2010-01-20 );
my ( $Path, $Script ) = map { m{^(.+)/([^/]+)$} } $0;    # instead of fileparse

################################################################################
################################################################################
# CUSTOMIZE THESE SETTINGS TO MATCH YOUR REQUIREMENTS:
#
my $config = {
    ## file locations: can only be overwritten by command-line parameters
    -config => "$Path/qlicserver.config",
    -limits => "$Path/qlicserver.limits",

    ## fallback configuration - can be removed or left empty as desired
    -defaultConfig => qq{
<?xml version="1.0"?>
<qlicserverConfig>
<!--
  <parameters type="overwrite">
   <param name="delay">30</param>
   <param name="timeout">10</param>
   <param name="ppid">ppid</param>
  </parameters>
-->
<!--
   | Map resource names (complexes) to values (features)
   | served by the license manager(s).
   | Resources without a "served" attribute are considered internal
   | Resources with type "track" are reported but not managed
   | The urgency is how much extra weight to give to particular resources.
   | If a 'slot' is weighted with 1000, we can give an extra 10% to
   | a few resources. [Format: INTEGER]
   |
   | The resource 'limit' specifies an upper limit to prevent applications
   | from flooding the cluster and/or prevent jobs from consuming all the
   | available licenses. A negative limit is subtracted from the total
   | to obtain the limit. [Format: INTEGER]
   |
   | Derived resources are combined from sub-elements and inherit the
   | limits from their sub-elements.
   |
   | Resources that are not served and not derived are internal resources
   + -->
<!--
 <resources type="overwrite">
  <!-- cfd applications
   <resource name="foam"/>
   <resource name="starjob" served="starpar" type="job" urgency="100" note="STAR-CD parallel starter"/>
   <resource name="starp"   served="hpcdomains" note="STAR-CD parallel"/>
   <resource name="stars"   served="starsuite" limit="2" note="STAR-CD serial"/>
   <derived name="starcd">
    <element>starp</element>
    <element>stars</element>
   </derived>

  <!-- fea applications
   <resource name="abaqus"   served="abaqus" type="job"/>
   <resource name="hyper"    served="GridWorks"/>
   <resource name="nastran1" served="NASTRAN" from="auglic1"/>
   <resource name="nastran2" served="NASTRAN" from="auglic2"/>
   <derived name="nastran">
    <element>nastran1</element>
    <element>nastran2</element>
   </derived>
   <resource name="thomat" note="abaqus high temp modelling" type="job"/>

  <!-- other applications
   <resource name="gtpower" served="GTpowerX" limit="4"/>

  <!-- tracked applications
   <resource name="gtise"   served="GTise"   type="track"/>
   <resource name="hexa"    served="aihexa"  type="track"/>
   <resource name="med"     served="aimed"   type="track"/>
   <resource name="proam"   served="proam"   type="track"/>
   <resource name="prostar" served="prostar" type="track"/>

 </resources>
-->
</qlicserverConfig>
},

};

#
#
# END OF CUSTOMIZE SETTINGS
################################################################################
################################################################################

# ------------------------------------------------------------------------------
sub usage {
    $! = 0;    # clean exit
    warn "@_\n" if @_;
    die <<"USAGE";
usage: $Script [OPTION] [PARAM]
  Query availability of floating licenses for the GridEngine.

help/debug options:
  -h        help

initialization options:
  -c        show complex definitions (format as per 'qconf -sc')
            for possible inclusion via 'qconf -Mc ...'

  -C        provide initial values for
            'qconf -mattr exechost complex_values ... global'

  -i        information about license features
            (generates text for the config lookup table)

query options:
  -l resource=value,...

            similar to qsub(1), query the license server for the availability
            of the requested resources. A missing value is treated as 1.
            The resource 'slots' will be used to scale the resource requests
            as required. Prints the resources available and exits with '99' if
            the condition cannot be satisfied. Only externally served resources
            are checked - resources internal to the GridEngine should never
            need this check.

  -n        suppress adjustment of the managed licenses (useful for testing)

daemon options:
  -d        run query as a daemon

  -k        kill running daemon

  -w        wake-up daemon from sleep

params:
  dir=DIR
            base directory for output,qhost,qstat parameters

  output=FILE
            save query status to FILE

  qhost=FILE
            add extra qhost query and save status to FILE

  qstat=FILE
            save qstat query to FILE

  timeout=N
            command timeout in seconds (default: 10 seconds)

  LM_LICENSE_FILE=STRING
            override environment setting for server query

  lmutil=STRING
            fully qualified path to lmutil command

  SGE_CLUSTER_NAME=STRING
            provide cluster name

static params:
  delay=N
            waiting period in seconds between queries in daemon mode
            (a delay of 0 is interpreted as 30 seconds)

  ppid=(ppid | N | CMD)
            which parent process id to watch in daemon mode.
            This can be decisive for migration etc.
                ppid = watch the lauching parent (default)
                CMD  = watch a particular process
                N    = watch a particular pid

command-line params:
  debug     emit debug information for the developer

  config=FILE
            specify alternative configuration file
            (default: $config->{-config})

  limits=FILE
            specify alternative limits file/directory
            (default: $config->{-limits})

This program has 2 major modes:
  1. Adjust the number of managed licenses, based on license availability
     and the number of granted resources (as determined by 'qstat') using the
     'qconf -mattr exechost complex_values ... global' command

  2. Query the license server for the availability of requested resources.
     Exit with '99' (requeue) if the condition cannot be satisfied.
     Prints the resources available.

FILES:
  The configuration can be hardcoded into this program and/or controlled
  via an XML configuration file:
      $config->{-config}

  The current limits for the resources are specified here:
      $config->{-limits}

  This can be either an XML file, or a directory.
  When it is a directory, the limits are specified as a single digit
  in each file that corresponds to a resource name.

NOTES:
  Further information about the configuration can be found on the wiki
  http://wiki.gridengine.info/wiki/index.php/Olesen-FLEXlm-Configuration

  This code is provided as a courtesy to other users with absolutely no
  guarantees!  Post usage questions to the users\@gridengine.sunsource.net
  mailing list - please do not email the author directly.

version ($releaseDate)
copyright (c) 2003-10 <Mark.Olesen\@faurecia.com>

Licensed and distributed under the Creative Commons
Attribution-NonCommercial-ShareAlike 3.0 License.
http://creativecommons.org/licenses/by-nc-sa/3.0
USAGE
}

# ------------------------------------------------------------------------------
my ( %opt, %cmdParam );
getopts( "hcCdikl:nw", \%opt ) or usage();
$opt{h} and usage();
my $Debugging;

# extract command-line parameters of the form param=value
for (@ARGV) {
    if (/^([A-Za-z]\w*)=(.+?)$/) {
        $cmdParam{$1} = $2;
    }
    elsif (/^([A-Za-z]\w*)$/) {
        $cmdParam{$1} = undef;
    }
}

# add debugging
if ( exists $cmdParam{debug} ) {
    $Debugging++;
}

# override file locations: command-line parameters only
for (qw( config limits )) {
    if ( exists $cmdParam{$_} ) {
        $config->{"-$_"} = $cmdParam{$_};
    }
}

# ------------------------------------------------------------------------------

#
# change hash references to a comma-delimited string of key=value entries
#
sub hashrefToString {
    join ',' => map {
        my $r = $_;
        ref $r ? join ',' => map { "$_=$r->{$_}" } sort keys %$r : '';
    } @_;
}

#
# extract attrib="value" ... attrib="value"
#
sub parseXMLattrib {
    my $str = shift || '';
    my %attr;

    while ($str =~ s{^\s*(\w+)=\"([^\"]*)\"}{}s
        or $str =~ s{^\s*(\w+)=\'([^\']*)\'}{}s )
    {
        $attr{$1} = $2;
    }

    %attr;
}


#
# resolve output file name from the config->{-parameter}
# relative to output 'dir'
# stdout (-) and absolute names are left untouched,
# as are names in the current working directory (starting with "./")
#
sub resolveOutputFile {
    my $name = shift;

    my $file;
    my $dir = $config->{-parameter}{dir};
    if ( exists $config->{-parameter}{$name}
        and defined $config->{-parameter}{$name} )
    {
        $file = $config->{-parameter}{$name};

        if (    defined $dir
            and length $dir
            and $file !~ m{^\.?/}
            and $file ne "-" )
        {
            -d $dir or mkdir $dir;
            $file = "$dir/$file";
        }
    }

    return $file;
}

#
# update the configuration as required
#
sub updateConfig {
    my $configFile    = $config->{-config};
    my $defaultConfig = $config->{-defaultConfig};

    $config->{-configUpdate} ||= 0;    # previous file update time

    my $needUpdate;
    keys %{ $config->{-resources} } or $needUpdate++;    # first-time

    my $fileString;
    if ( defined $configFile and -f $configFile and -r _ ) {
        my $mtime = ( stat $configFile )[9];

        if ( $config->{-configUpdate} < $mtime ) {
            $fileString = do {
                local *FILE;
                local $/;
                if ( open FILE, $configFile ) {
                    $needUpdate++;
                    <FILE>;
                }
                else {
                    undef;
                }
            };

            $config->{-configUpdate} = $mtime;
        }
    }

    return unless $needUpdate;

    # clear old values
    $config->{-parameter} = {};    # command-line and file '<param>' entries
    $config->{-resources} = {};    # all the resources, original parameters
    $config->{-derived}   = {};    # derived resources only
    $config->{-intern}    = {};    # internal resources only
    $config->{-managed}   = {};    # managed internal/external/derived resources
    $config->{-lookup}    = {};    # reverse lookup (complex -> resource)
    $config->{-mapFrom}   = {};    # (optional) mapping based on server

    # config precedence:
    #   -defaultConfig (hard-coded)
    #   -config  (FILE)

    # parameters precedence:
    #   -defaultConfig (hard-coded)
    #   -config  (FILE)
    #   command-line

    my ( %cfg, %param );
    for ( $defaultConfig, $fileString ) {
        defined or next;

        # strip out all xml comments
        s{<!--.*?-->\s*}{}sg;

        ## an overwrite mechanism for 'parameters' and 'resources'
        if (s{<(parameters|resources) \s*([^<>]+) >}{}sx) {
            my ( $tag, $attr ) = ( $1, $2 );
            my %attr = parseXMLattrib($attr);
            my $type = delete $attr{type};
            if ( defined $type and $type eq "overwrite" ) {
                if ( $tag eq "parameters" ) {
                    %param = ();
                }
                elsif ( $tag eq "resources" ) {
                    %cfg = ();
                }
            }
        }

        ## process <param ...> .. </param>
        while (s{<param \s+([^<>]+) > (.+?) </param>}{}sx) {
            my ( $attr, $value ) = ( $1, $2 );
            my %attr = parseXMLattrib($attr);
            my $name = delete $attr{name};
            if ( defined $name ) {
                $value =~ s{^\s+|\s+$}{}g;
                $param{$name} = $value;
            }
        }

        ## process <resource .../> and <resource ...> .. </resource>
        while (s{<resource \s+([^<>]+?) />}{}sx
            or s{<resource \s+([^<>]+) > (.*?) </resource>}{}sx )
        {
            my ( $attr, undef ) = ( $1, $2 );
            my %attr = parseXMLattrib($attr);
            my $name = delete $attr{name};
            ## overwrite old value
            if ( defined $name ) {
                $cfg{$name} = {%attr};
            }
        }

        ## process <derived ...> CONTENT </derived>
        while (s{<derived \s+([^<>]+) > (.+?) </derived>}{}sx) {
            my ( $attr, $content ) = ( $1, $2 );
            my %attr = parseXMLattrib($attr);
            my $name = delete $attr{name};
            if ( defined $name ) {
                delete $attr{served};    # derived are not served
                delete $cfg{$name};

                my @elem;
                ## process <element> ... </element>
                while ( $content =~ s{<element> \s*(\w+)\s* </element>}{}sx ) {
                    push @elem, $1;
                }

                if (@elem) {
                    $cfg{$name} = {%attr};
                    $cfg{$name}{element} = [@elem];
                }
            }
        }
    }

    for ( keys %cmdParam ) {
        $param{$_} = $cmdParam{$_};
    }

    # assign the parameters
    %{ $config->{-parameter} } = %param;

    for my $name ( keys %cfg ) {
        ## All managed complexes are 'consumable' (mark as zero)
        ## unless otherwise noted
        my $type;
        if ( exists $cfg{$name}{type} ) {
            $type = $cfg{$name}{type};
        }
        $type ||= 0;

        if ( exists $cfg{$name}{element} ) {
            ## transfer derived information
            # NB: probably can only have normal consumables
            $config->{-derived}{$name} = delete $cfg{$name};
        }
        elsif ( exists $cfg{$name}{served} ) {
            ## create served -> resource lookup
            my $served = $cfg{$name}{served};

            if ( exists $cfg{$name}{from} ) {
                ## insert server-specific remapping, server name in lowercase
                for ( map { split } lc $cfg{$name}{from} ) {
                    $config->{-mapFrom}{$_}{$served} = $name;

                    # since remapping occurs in the query,
                    # '-lookup' is an identity
                    $config->{-lookup}{$name} = [ $name, $type ];
                }
            }
            else {
                $config->{-lookup}{$served} = [ $name, $type ];
            }
        }
        else {
            ## not served and not derived -> internal resource
            ## transfer information
            $config->{-intern}{$name} = delete $cfg{$name};
        }

        ## only tracked resources are unmanaged
        $config->{-managed}{$name} = $type unless $type =~ /track/i;
    }

    # assign the rest
    %{ $config->{-resources} } = %cfg;

    ## TODO:
    ## check that the derived type is consistently job/non-job

    # update parameters:
    # adjust timeout - the license server is the Achilles heel
    if ( exists $config->{-parameter}{timeout} ) {
        Shell->timeout( $config->{-parameter}{timeout} );
    }

    # adjust the license manager environment(s) and command(s)
    for (@License::Manager) {
        eval {
            my $name = $_->envname();
            if ( defined $name and exists $config->{-parameter}{$name} ) {
                $_->setenv( $config->{-parameter}{$name} );
            }
        };

        eval {
            my $name = $_->cmdname();
            if ( defined $name and exists $config->{-parameter}{$name} ) {
                $_->setcmd( $config->{-parameter}{$name} );
            }
        };
    }
}

#
# extract limits from the specified file:
#  <?xml version="1.0"?>
#  <qlicserverLimits>
#    <limits>
#      <limit name="gtpower" limit="7"/>
#      <limit name="stars"   limit="2"/>
#      <limit name="starp"   limit="20"/>
#    </limits>
#  </qlicserverLimits>
#
# OR from files within the specified directory:
# The limits are specified as a single digit in each file that corresponds
# to a resource name. Negative limits are deducted from the total.
#
sub updateLimits {
    my $diskValues = $config->{-limits};
    my $limits;

    # get defaults
    for my $href (
        $config->{-intern},       ##
        $config->{-resources},    ##
        $config->{-derived},      ##
      )
    {
        for my $name ( keys %$href ) {
            if ( exists $href->{$name}{limit} ) {
                my $limit = $href->{$name}{limit};
                if ( defined $limit ) {
                    $limits->{$name} = $limit;
                }
            }
        }
    }

    my $fileString;
    if ( defined $diskValues and -f $diskValues ) {
        ## read from a single file (xml format)
        $fileString = do {
            local *FILE;
            local $/;
            if ( open FILE, $diskValues ) {
                <FILE>;
            }
            else {
                undef;
            }
        };
    }
    elsif ( defined $diskValues and -d $diskValues ) {
        ## read from multiple files (text format)
        local *DIR;
        my $dir = $diskValues;
        if ( opendir DIR, $dir ) {
            my @files = grep { -f "$dir/$_" and -s _ } readdir DIR;
            for my $name (@files) {
                my $limit;

                # use the last value
                if ( open FILE, "$dir/$name" ) {
                    $limit = ( map { /^\s*(-?\d+)\s*$/ } <FILE> )[-1];
                }
                if ( defined $limit ) {
                    $limits->{$name} = $limit;
                }
            }
        }
    }

    for ($fileString) {
        defined or next;

        # strip out all xml comments
        s{<!--.*?-->\s*}{}sg;

        ## process <limit .../> and <limit ...></limit>
        while (s{<limit \s+([^/<>]+) />}{}sx
            or s{<limit \s+([^/<>]+) >\s*</limit>}{}sx )
        {
            my %attr  = parseXMLattrib($1);
            my $name  = delete $attr{name};
            my $limit = delete $attr{limit};
            if ( defined $name and defined $limit ) {
                $limits->{$name} = $limit;
            }
        }
    }

    # negative limits on internal resources are only possible
    # when a total is known
    for my $name ( keys %$limits ) {
        if (    $limits->{$name} < 0
            and exists $config->{-intern}{$name}
            and not exists $config->{-intern}{$name}{total} )
        {
            delete $limits->{$name};
        }
    }

    $limits;
}

#
# Prototype: mungeLicenses( HASHREF1 [, HASHREF2, [, HASHREF3]] )
#
# HASHREF1 => {         # from the license manager
#    feature => {
#       total => NUM,
#       "user@machine nlicense" => occurances,
#       "*user@machine" => NUM,         ## waiting licenses
#       ...
#    },
# }
#
# HASHREF2 => {         # from qstat
#    complex => {
#       waiting => {
#          "user" => NUM,
#       },
#       jobid => {
#          "user@machine nlicense" => occurances,
#          ...
#       },
#       total => NUM,  # iff. an internal tracked value
#    },
# }
#
# HASHREF3 => {         # ulimit
#    complex => NUM,
# }
#
# munge into
#
# HASHREF => {
#    complex => {
#       extern  => NUM,
#       intern  => NUM,
#       limit   => NUM,
#       total   => NUM,
#       waiting => NUM,
#       served  => STRING,
#       users   => {
#           extern  => { "user@machine" => NUM, },
#           intern  => { "user@machine" => NUM, },
#           waiting => { "user" => NUM, },
#       },
#    },
# }
#
sub mungeLicenses {
    my $served   = shift;
    my $consumed = shift || {};
    my $limits   = shift || {};
    my $report   = {};

    #
    # cast the interesting features into the desired format.
    # include 'intern' usage, but do not adjust 'extern' yet.
    #
    for my $feature ( keys %$served ) {
        my $externUsers = $served->{$feature} or next;
        exists $config->{-lookup}{$feature} or next;
        my ( $resource, $type ) = @{ $config->{-lookup}{$feature} };

        # remove 'total' from hash
        my $total = delete $externUsers->{total} || 0;

        # internal job allocation, jobs waiting
        my $internUsers  = delete( $consumed->{$resource} )  || {};
        my $waitingUsers = delete( $internUsers->{waiting} ) || {};

        # potential management limits
        # negative limit implies subtract from total
        my $limit = $limits->{$resource};
        if ( defined $limit ) {
            $limit += $total if $limit < 0;
            $limit = 0 if $limit < 0;
        }
        defined $limit and $limit < $total or $limit = $total;

        $report->{$resource} = {
            type   => $type,
            served => $feature,
            total  => $total,
            limit  => $limit,
            users  => {
                extern  => $externUsers,
                intern  => $internUsers,
                waiting => $waitingUsers,
            },
        };
    }

    #
    # add in internal features
    #
    for my $resource ( keys %$consumed ) {
        my $total = delete $consumed->{$resource}{total};
        defined $total or next;

        # internal job allocation, jobs waiting
        my $internUser  = delete( $consumed->{$resource} ) || {};
        my $waitingUser = delete( $internUser->{waiting} ) || {};

        # potential management limits
        # negative limit implies subtract from total
        my $limit = $limits->{$resource};
        if ( defined $limit ) {
            $limit += $total if $limit < 0;
            $limit = 0 if $limit < 0;
        }
        defined $limit and $limit < $total or $limit = $total;

        $report->{$resource} = {
            type  => "intern",
            total => $total,
            limit => $limit,
            users => {
                extern  => {},
                intern  => $internUser,
                waiting => $waitingUser,
            },
        };
    }

    # derived resources
    #   - external licenses are the external licenses of the components
    #   - the derived sub-resources may be reported/managed themselves
    #     or simply available directly from the server
    for my $resource ( keys %{ $config->{-derived} } ) {
        my $internUser  = delete( $consumed->{$resource} ) || {};
        my $waitingUser = delete( $internUser->{waiting} ) || {};

        my $entry = $report->{$resource} = {
            total => 0,
            limit => 0,
            users => {
                extern  => {},
                intern  => $internUser,
                waiting => $waitingUser,
            },
        };

        for my $subResource ( @{ $config->{-derived}{$resource}{element} } ) {
            my $part;

            ## reported sub-resource - already in the correct structure
            if ( exists $report->{$subResource} ) {
                $part = $report->{$subResource};
            }
            elsif ( exists $served->{$subResource} ) {
                ## served sub-resource - adjust into correct structure
                $part = { -extern => { %{ $served->{$subResource} } } };
                my $total = delete $part->{-extern}{total} || 0;

                $part->{total} = $part->{limit} = $total;
            }

            defined $part or next;    # not reported/managed and not served

            # collect total/limit and extern
            $entry->{total} += $part->{total} || 0;
            $entry->{limit} += $part->{limit} || 0;
            for ( keys %{ $part->{users}{extern} } ) {
                $entry->{users}{extern}{$_} += $part->{users}{extern}{$_};
            }
        }

        # the specified limit might be more stringent than that determined
        # from the sub-resources
        my $limit = $limits->{$resource};
        if ( defined $limit ) {
            if ( $entry->{limit} > $limit ) {
                $limit += $entry->{total} if $limit < 0;
                $limit = 0 if $limit < 0;
                $entry->{limit} = $limit;
            }
        }
    }

    # - remove usage that is already accounted for
    # - remove non-existent / implausible entry
    # - prepend jobid.taskid with -ve to prevent it from being
    #   processed more than once
    my $juggle = sub {
        my ( $externUser, $internUser ) = @_;

        for my $jobIdent ( grep { /^\d+[\.\d]*$/ } keys %$internUser ) {
            for ( keys %{ $internUser->{$jobIdent} } ) {
                if (    $externUser->{$_}
                    and $externUser->{$_} >= $internUser->{$jobIdent}{$_} )
                {
                    $externUser->{$_} -= $internUser->{$jobIdent}{$_};
                    $internUser->{"-$jobIdent"}{$_} =
                      delete $internUser->{$jobIdent}{$_};
                    $externUser->{$_} > 0 or delete $externUser->{$_};
                }
            }
            ## remove empty hash references
            keys %{ $internUser->{$jobIdent} }
              or delete $internUser->{$jobIdent};
        }
    };

    for my $resource ( keys %$report ) {
        my $entry        = $report->{$resource};
        my $externUsers  = $entry->{users}{extern} or next;    # cannot happen
        my $internUsers  = $entry->{users}{intern} or next;
        my $waitingUsers = $entry->{users}{waiting} ||= {};

        #
        # juggle extern/intern consumption
        #
        $juggle->( $externUsers, $internUsers );

        #
        # reduce extern/intern user to canonical form
        #  "user@host" => count
        #
        for ( [ extern => $externUsers ], [ intern => $internUsers ] ) {
            my ( $label, $ref ) = @$_;
            for my $r ( $label =~ /intern/ ? values %$ref : $ref ) {
                my %hash;
                for ( keys %$r ) {
                    my ( $key, $value ) = split;
                    defined $value or $value = 1;    # for pre-reduced format
                    my $count = $r->{$_};
                    $hash{$key} += $value * $count;
                }
                %$r = %hash;
            }
        }

        #
        # juggle again - licenses may be split across several groups or servers
        #
        $juggle->( $externUsers, $internUsers );

        #
        # collapse one level of indirection and drop job numbers
        #   user/intern => {
        #     jobid => {
        #       "user@machine" => count,
        #     },
        #   },
        # -->
        #   user/intern => {
        #     "user@machine" => count,
        #   },
        %$internUsers = do {
            my %hash;
            for my $ref ( values %$internUsers ) {
                $hash{$_} += $ref->{$_} for keys %$ref;
            }
            %hash;
        };

        # add licenses reported as waiting by FlexLM
        for ( grep { /^\*/ } keys %$externUsers ) {
            $waitingUsers->{$_} += delete $externUsers->{$_};
        }

        # remove needless limiters
        if ( $entry->{limit} >= $entry->{total} ) {
            delete $entry->{limit};
        }

        # summarize the hashes to -> count
        for (
            [ extern  => $externUsers ],
            [ intern  => $internUsers ],
            [ waiting => $waitingUsers ],
          )
        {
            my ( $label, $ref ) = @$_;
            my $total;
            $total += $_ for values %$ref;
            $entry->{$label} = $total || 0;
        }
    }

    return $report;
}

#
# Prototype qlic_output(fileName, HASHREF1, HASHREF2)
#
# HASHREF1 => {
#    feature => {
#       extern  => NUM,
#       intern  => NUM,
#       limit   => NUM,
#       total   => NUM,
#       waiting => NUM,
#       served  => STRING,
#       user    => {
#           extern  => { "user@machine" => NUM, },
#           intern  => { "user@machine" => NUM, },
#           waiting => { "user" => NUM, },
#       },
#    },
# }
#
#
# HASHREF2 => {   # the changes
#    feature => NUM,
# }
#
sub qlic_output {
    my $cacheFile = shift;
    my $report    = shift;
    my $mattr     = hashrefToString(shift) || "NONE";

    defined $cacheFile and length $cacheFile or return;

    # use temp file with rename to avoid race conditions
    my $tmpFile = $cacheFile;
    if ( $cacheFile ne "-" ) {    # catch "-" STDOUT alias
        $tmpFile .= ".TMP";
        unlink $tmpFile;
    }
    local *FILE;
    open FILE, ">$tmpFile" or return;

    # write dates, administration information, some environment variables
    my $time = time;
    my $date = POSIX::strftime( "%FT%T", localtime $time );
    my $host = ( POSIX::uname() )[1];
    my $user = getpwuid $<;

    # cluster names/locations
    my $sgeRoot = $ENV{SGE_ROOT} || "";
    my $sgeCell = $ENV{SGE_CELL} || "default";

    # cluster name is not standard - maybe from env or config file
    my $clusterName = $ENV{SGE_CLUSTER_NAME} || "";

    # cluster name might just be in the config information
    if ( exists $config->{-parameter}{SGE_CLUSTER_NAME} ) {
        my $value = $config->{-parameter}{SGE_CLUSTER_NAME};
        if ( defined $value and length $value ) {
            $clusterName = $value;
        }
    }
    # $clusterName ||= "default";    ## fallback value
    $clusterName = "default";    ## always use "default"


    # header with comment about possible changes
    print FILE << "XML_TEXT";
<?xml version="1.0"?>
<?qlicserver date="$date"?>
<qlicserver releaseDate="$releaseDate">
<!-- adjustment:
     qconf -mattr exechost complex_values $mattr global
-->
 <query>
  <cluster name="$clusterName" root="$sgeRoot" cell="$sgeCell"/>
  <host>$host</host>
  <user>$user</user>
  <time epoch="$time">$date</time>
 </query>
 <parameters>
XML_TEXT

    # environment
    for (qw( SGE_ROOT SGE_CELL SGE_ARCH SGE_BINARY_PATH SGE_qmaster )) {
        if ( $ENV{$_} ) {
            print FILE qq{  <env name="$_">$ENV{$_}</env>\n};
        }
    }

    # show inherited license environment(s)
    for (@License::Manager) {
        my ( $name, $value ) = ( $_->envname(), $_->envvalue() );
        if ( defined $name and not exists $config->{-parameter}{$name} ) {
            print FILE qq{  <env name="$name">}
              . ( $value || '' )
              . qq{</env>\n};
        }
    }

    # other parameters
    for ( sort keys %{ $config->{-parameter} } ) {
        my $value = $config->{-parameter}{$_};
        if ( defined $value and length $value ) {
            print FILE qq{  <param name="$_">$value</param>\n};
        }
    }

    # finish parameters and start resources
    print FILE                 ##
      qq{ </parameters>\n},    ##
      qq{ <resources>\n};

    for my $name ( sort keys %{ $config->{-derived} } ) {
        my @elem = @{ $config->{-derived}{$name}{element} };
        if (@elem) {
            print FILE +(
                qq{  <derived name="$name">\n},
                ( map { qq{   <element>$_</element>\n} } @elem ),
                qq{  </derived>\n},
            );
        }
    }

    for my $resource ( sort keys %$report ) {
        my $entry = $report->{$resource}
          or warn "(WW) '$resource' not defined\n"
          and next;

        # hash some output values here:
        my %output = (
            name => $resource,
            ( map { $_ => $entry->{$_} } qw( served type waiting ) )
        );

        my ( $total, $limit, $extern, $intern ) =
          @{$entry}{qw( total limit extern intern )};

        my $managed = ( $total - $extern );

        if ( defined $limit and $limit < $total ) {
            if ( $managed > $limit ) {
                $managed = $limit;
            }
        }
        else {
            undef $limit;
        }

        my $free = $managed - $intern;

        $_ >= 0 or $_ = 0 for ( $free, $managed );    # should not be required

        # transcribe directly from original data structure
        if ( exists $config->{-resources}{$resource} ) {
            my $rc = $config->{-resources}{$resource};

            for (qw( served from note )) {
                if ( exists $rc->{$_} ) {
                    $output{$_} = $rc->{$_};
                }
            }
        }

        print FILE qq{  <resource};
        for (
            [ name    => $output{name} ],
            [ served  => $output{served} ],
            [ from    => $output{from} ],
            [ total   => $total ],
            [ limit   => $limit ],
            [ extern  => $extern ],
            [ intern  => $intern ],
            [ waiting => $output{waiting} ],
            [ free    => $free ],
            [ type    => $output{type} ],
            [ note    => $output{note} ],
          )
        {
            my ( $k, $v ) = @$_;
            if ( $k =~ /(total|limit)/ ) {
                ## unconditional output
                print FILE qq{ $k="$v"} if defined $v;
            }
            else {
                print FILE qq{ $k="$v"} if $v;
            }
        }

        my $output;    # track if anything was written
        my $users = $entry->{users} || {};

        for (          ##
            [ extern  => $users->{extern} ],     ##
            [ intern  => $users->{intern} ],     ##
            [ waiting => $users->{waiting} ],    ##
          )
        {
            my ( $label, $ref ) = @$_;
            my %user;
            $user{$_} += $ref->{$_} || 0 for keys %$ref;

            # output users
            for my $tag ( sort keys %user ) {
                my $count = $user{$tag};
                if ($count) {
                    my ( $name, $host ) = split /\@/, $tag;

                    if ( not $output++ ) {
                        print FILE qq{>\n};
                    }
                    print FILE qq{   <user name="$name"}
                      . ( $host ? qq{ host="$host"} : '' )
                      . qq{ type="$label"}
                      . qq{>$count</user>\n};
                }
            }
        }

        # finish contents or finish as an empty element
        if ($output) {
            print FILE qq{  </resource>\n};
        }
        else {
            print FILE qq{/>\n};
        }
    }

    # footer
    print FILE                ##
      qq{ </resources>\n},    ##
      qq{</qlicserver>\n};

    close FILE;               # explicitly close before rename
    if ( $tmpFile ne $cacheFile ) {
        chmod 0444      => $tmpFile;      # output cache is readonly
        rename $tmpFile => $cacheFile;    # atomic
    }
}

#
# get the pid of a command
#
sub pidof {
    my $cmd = shift;
    map { /^\s*(\d+)\s*$/ } qx{/bin/ps -C $cmd -o pid= 2>/dev/null};
}

#
# kill programs with the same name as this program
#
sub kill_daemon {
    my $signal = shift || 9;
    my @list = grep { $_ != $$ } pidof($Script);
    kill $signal => @list if @list;
}

# ------------------------------------------------------------------------------
# '-k'
# terminate processes
# ------------------------------------------------------------------------------
if ( $opt{k} ) {
    kill_daemon 15;    # TERM
    exit 0;
}

# ------------------------------------------------------------------------------
# '-w'
# wakeup daemon
# ------------------------------------------------------------------------------
if ( $opt{w} ) {
    kill_daemon 10;    # USR1
    exit 0;
}

# for rest of the options, we need an updated configuration
updateConfig();

# ------------------------------------------------------------------------------
# '-c' / '-C'
# configuration
# ------------------------------------------------------------------------------
if ( $opt{C} or $opt{c} ) {

    #
    # show complexes (format as per 'qconf -sc');
    #
    if ( $opt{c} ) {
        print <<'PRINT';
#
# complexes for re-importing via "qconf -mc",
# licenses mostly weighted with '0' urgency (slot count used instead)
#
# name shortcut type relop requestable consumable default urgency
# ------------------------------------------------------------------------------
PRINT
        for my $name ( sort keys %{ $config->{-managed} } ) {
            my $consumable =
              $config->{-managed}{$name} =~ /job/i ? "JOB" : "YES";
            my $urgency = 0;

            # brute-force search for urgency
            for my $href (
                $config->{-resources},    #
                $config->{-derived},      #
                $config->{-intern},       #
              )
            {
                if ( exists $href->{$name} ) {
                    if ( exists $href->{$name}{urgency} ) {
                        $urgency = $href->{$name}{urgency};
                    }
                    last;
                }
            }
            print "$name\t$name\tINT\t<=\tYES\t$consumable\t0\t$urgency\n";
        }
    }

    if ( $opt{C} ) {
        my $qconf = Qconf->query();

        ## ignore complexes that are already known
        delete @{ $config->{-managed} }{ keys %$qconf };

        if ( %{ $config->{-managed} } ) {
            ## initialize all values with zero
            for ( values %{ $config->{-managed} } ) {
                $_ = 0;
            }

            print <<'PRINT';
# initialize remaining managed resources with the following command:
PRINT
            print "    qconf -mattr exechost complex_values ",
              hashrefToString( $config->{-managed} ), " global\n\n";
        }
        else {
            print "# nothing to do\n";
        }
    }

    exit 0;
}

# ------------------------------------------------------------------------------
# '-i'
# query the license servers for available license features
# ------------------------------------------------------------------------------
if ( $opt{i} ) {
    my $license = License->query();

    # header
    print << 'XML_TEXT';
<?xml version="1.0"?>
<qlicserverConfig>
<!-- NOTE:
   | This is a configuration fragment of served resources.
   | It is missing limits, urgency and derived, internal and remapped resources.
   | DO NOT USE THIS FILE DIRECTLY AS YOUR CONFIGURATION FILE.
   + -->
 <resources>
XML_TEXT

    my @new;
    for ( sort keys %$license ) {
        my ( $type, $feature, $resource ) = ( "", $_, lc $_ );

        if ( exists $config->{-lookup}{$feature} ) {
            ( $resource, $type ) = @{ $config->{-lookup}{$feature} };
            print qq{  <resource name="$resource" served="$feature"};
            if ($type) {
                print qq{ type="$type"};
            }
            else {
                my %h = %{ $config->{-resources}{$resource} };
                delete $h{served};
                for ( sort keys %h ) {
                    print qq{ $_="$h{$_}"};
                }
            }
            print qq{/>\n};
        }
        else {
            push @new, $feature;
        }
    }

    # footer
    print << 'XML_TEXT';
</resources>
</qlicserverConfig>
XML_TEXT

    if (@new) {
        print << 'XML_TEXT';

<!--
    NEW SERVED FEATURES DISCOVERED
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
XML_TEXT

        for (@new) {
            print qq{    <resource name="\L$_\E" served="$_"/>\n};
        }
        print qq{-->\n};
    }

    exit 0;
}

# ------------------------------------------------------------------------------
# '-l resource=value,...'
# query the license server for the availability
# ------------------------------------------------------------------------------
if ( $opt{l} ) {

    # only check served/derived resources, to avoid extra qconf -se
    # and since this check should be unnecessary for internal resources anyhow
    delete @{ $config->{-managed} }{ keys %{ $config->{-intern} } };

    # comma -> space-delimited, extracting 'slots' along the way
    my $slots;
    my @list =
      map {
        my ( $rc, $request ) = split /=+/;
        defined $request and $request =~ /^\d+\.?\d*$/ or $request ||= 1;

        if ( exists $config->{-managed}{$rc} ) {
            [ $rc => $request ];
        }
        else {
            ## number of slots ('slots=' or 's=')
            $slots = $request if $rc =~ /^(?:s|slots)$/;
            ();
        }
      }
      map { s{,}{ }g; split; } $opt{l};

    @list or exit 0;

    # qstat query
    my $qstat = GridEngine->qstat(
        undef,                 ## without file caching
        $config->{-managed}    ## distinguish complex types
    );

    # get my own job identifier from the environment
    # treat non-array job (task=undefined) as task=0
    ( my $jobIdent = ( $ENV{JOB_ID} || 0 ) . '.' . ( $ENV{SGE_TASK_ID} || 0 ) )
      =~ s/[a-z]+$/0/i;

    # never count myself in the overal balance, otherwise we block our own way!
    for ( values %$qstat ) {
        delete $_->{$jobIdent};
    }

    # get the projected resource availability:
    my $licenses = mungeLicenses(
        License->query( $config->{-mapFrom} ),    ## license availability
        $qstat,                                   ## qstat query
        updateLimits()                            ## limits are interesting
    );

    my $failed;
    $slots ||= 1;                                 # safety
    for (@list) {
        my ( $rc, $request ) = @$_;
        if ( exists $licenses->{$rc} ) {          # safety
            my ( $total, $limit, $extern, $intern ) =
              @{ $licenses->{$rc} }{qw( total limit extern intern )};

            my $managed = ( $total - $extern );

            if ( defined $limit and $limit < $total ) {
                if ( $managed > $limit ) {
                    $managed = $limit;
                }
            }
            else {
                undef $limit;
            }

            my $free = $managed - $intern;

            if ( $free < 0 ) {
                $free = 0;
            }

            ## scale non-'job' consumables
            $request *= $slots unless $config->{-managed}{$rc} =~ /job/i;
            $request = sprintf "%.0f", $request;

            if ( $request > $free ) {
                $request = $free;
                $failed++;
            }
        }
        $_ = "$rc=$request";
    }
    print join( ',' => @list ), "\n";

    exit( $failed ? 99 : 0 );
}

# ------------------------------------------------------------------------------
# standard query, with optional '-d' (daemonize)
# ------------------------------------------------------------------------------
my $daemon = $opt{d};

if ($daemon) {    # daemonize

    # the delay between loops
    my $delay = $config->{-parameter}{delay};
    $daemon = ( $delay and $delay =~ /^\d+$/ ) ? $delay : 30;

    # terminate old processes
    kill_daemon 15;    # TERM

    # option 1 (default):
    #   - watch the pid of the original parent process
    # option 2:
    #   - watch the pid of a particular process (eg, sge_qmaster)
    # option 3:
    #   - watch a particular pid (a pid <= 1 implies a true daemon)

    my $ppid = getppid();    # get ppid before forking

    # we can can check this process quite simply
    *check_ppid = sub { kill 0 => $ppid };

    if ( exists $config->{-parameter}{ppid} ) {
        my $value = $config->{-parameter}{ppid};
        if ( $value ne "ppid" ) {
            if ( $value =~ /^\d+$/ ) {
                $ppid = $value;
            }
            else {
                ($ppid) = pidof($value);
                defined $ppid
                  or die "no pid for command '$value'  ... exiting\n";
            }

            no warnings 'redefine';
            if ( $ppid <= 1 ) {
                ## a true daemon - ignore the parent
                *check_ppid = sub { 1; };
            }
            else {
                ## kill 0 doesn't always work if we don't own the process
                ## use the /proc system if it seems to exist
                if ( -d "/proc/$$" and -d "/proc/$ppid" ) {
                    *check_ppid = sub { -d "/proc/$ppid"; };
                }
                else {
                    ## or revert to a more expensive system call
                    *check_ppid = sub {
                        system "/bin/ps -p $ppid -o pid= >/dev/null 2>&1";
                        ($?) ? 0 : 1;
                    };
                }
            }

            # test if we can watch this pid before attempting to fork
            check_ppid()
              or die "cannot watch ppid=$ppid '$value' ... exiting\n";
        }
    }

    #
    # this makes the code quasi-independent of the parent process
    # but should allow it to detect when the launching load-sensor
    # has restarted
    #
    *processing = sub {
        if ( $daemon > 0 and check_ppid() ) {
            ## daemon still running and ppid still alive
            sleep( $daemon || 0 );
        }
        else {
            ## ppid looks dead - let's die too
            $daemon = 0;
        }
        return $daemon;
    };

    my $pid = fork;
    exit if $pid;    # let parent exit
    defined $pid or die "Couldn't fork: $!";

    # a new process group for the child
    POSIX::setsid() or die "Can't start a new session: $!";
}
else {
    $daemon = 0;
    *processing = sub { $daemon = 0; };
}

if ($daemon) {
    ## Trap fatal signals, setting flag to exit gracefully
    $SIG{INT} = $SIG{TERM} = sub { $daemon = 0; };
    $SIG{PIPE} = "IGNORE";
    $SIG{USR1} = sub { sleep 0; };    # allow wake-up on demand
    $SIG{USR2} = sub {
        sleep 0;                      # wake-up
        $daemon = -1;                 # signal end
    };
}

#
# the main license query and 'qconf -mattr' code
# standard - execute once
# daemon   - loop until killed
#
do {
    updateConfig();

    my $limits = updateLimits();
    my $served = License->query( $config->{-mapFrom} );
    my $qconf  = Qconf->query();

    # qstat query and cache to a file
    my $qstat = GridEngine->qstat(
        resolveOutputFile("qstat"),    ## optional cache
        $config->{-managed}            ## distinguish complex types
    );

    # cache qhost query to a file
    GridEngine->qhost( resolveOutputFile("qhost") );

    # merge in the intern tracked resources
    # take total from config, for the limits or from qconf
    for ( keys %{ $config->{-intern} } ) {
        if ( exists $qconf->{$_} ) {
            if ( exists $config->{-intern}{$_}{total} ) {
                $qstat->{$_}{total} = $config->{-intern}{$_}{total};
            }
            elsif ( exists $limits->{$_} and $limits->{$_} >= 0 ) {
                $qstat->{$_}{total} = $limits->{$_};
            }
            else {
                $qstat->{$_}{total} = $qconf->{$_};
            }
        }
    }

    # assign 'total => 0' for managed licenses that were not
    # reported from the server (eg, server down)
    for ( keys %{ $config->{-lookup} } ) {
        $served->{$_} ||= { total => 0 };
    }

    my $licenses = mungeLicenses( $served, $qstat, $limits );
    my $change = Qconf->diff( $qconf, $licenses );

    # cache output to a file
    qlic_output( resolveOutputFile("output"), $licenses, $change );

    if ($Debugging) {
        $opt{n}++;
        eval {
            use Data::Dumper;
            warn Data::Dumper->Dump( [ $licenses, $change ],
                [qw(License Change)] ), "\n";
        };

        exit;
    }

    Qconf->mattr( hashrefToString($change) ) unless $opt{n};

} while processing();

exit 0;

# ------------------------------------------------------------------ end-of-main
# somewhat like the qx// command with a timeout mechanism,
# but for safety it only handles a list form (no shell escapes)
#

package Shell;
our ( $timeout, $report );

BEGIN {
    $timeout = 10;
}

#
# assign new value for reporting the timeout
#
sub report {
    my ( $caller, $value ) = @_;
    $report = $value;
}

#
# assign new timeout
#
sub timeout {
    my ( $caller, $value ) = @_;
    $timeout = ( $value and $value =~ /^\d+$/ ) ? $value : 10;
}

sub cmd {
    my ( $caller, @command ) = @_;
    my ( @lines, $pid, $redirected );
    local ( *OLDERR, *PIPE );

    # kill off truant child: this works well for unthreaded processes,
    # but threaded processes are still an issue
    local $SIG{__DIE__} = sub { kill TERM => $pid if $pid; };

    eval {
        local $SIG{ALRM} = sub { die "TIMEOUT\n" };         # NB: '\n' required
        alarm $timeout if $timeout;
        @command or die "$caller: Shell->cmd with an undefined query\n";

        if ( open OLDERR, ">&", \*STDERR ) {
            $redirected++;
            open STDERR, ">/dev/null";
        }

        $pid = open PIPE, '-|', @command;    # open without shell (forked)
        if ($pid) {
            @lines = <PIPE>;
        }

        die "(EE) ", @lines if $?;
        alarm 0;
    };

    # restore stderr
    open STDERR, ">&OLDERR" if $redirected;

    if ($@) {
        if ( $@ =~ /^TIMEOUT/ ) {
            warn "(WW) TIMEOUT after $timeout seconds on '@command'\n" if $report;
            return undef;
        }
        else {
            die $@;    # propagate unexpected errors
        }
    }

    wantarray ? @lines : join '' => @lines;
}

1;

# --------------------------------------------------------------- end-of-package
# FlexLM queries
#
# The env variable 'LM_LICENSE_FILE' contains a colon-delimited list
# with "port@server:port@server".
# The queries for the same server (but different ports) are grouped together
# and run in a common thread.
# eg,
#    port1@server1:port1@server2:port2@server1
# -> port1@server1:port2@server1 + port1@server2
# running in two threads.
#
# NOTE: for grouping to work, the servers must be named consistently
# eg,
#    port1@server1.domain:port2@server1:port3@server1.ip.addr
# -> port1@server1.domain + port2@server1 + port3@server1.ip.addr
#
# To suppress grouping by server, entries can be surrounded by brace brackets.
# eg,
#    port1@server1:port1@server2:{port2@server1}
# -> port2@server1 + port1@server1 + port1@server2
#
# or,
#    {port1@server1:port1@server2:port2@server1}
# -> port1@server1:port1@server2:port2@server1
#
#
# This behaviour can be useful when license server triads are in use.
# When a triad is in place, the single query to all three servers returns the
# correct information, whereas three separate queries would incorrectly return
# a triple count!
# eg,
#    port1@server1:{port@triad1:port@triad2:port@triad3}
# -> port@triad1:port@triad2:port@triad3 + port1@server1
#
# As a side-effect, entries enclosed in brace brackets will be queried first.
#
package Flexlm;
our ( $env, $cmd, @args, @servers );

BEGIN {
    $env  = $ENV{LM_LICENSE_FILE};
    $cmd  = "lmutil";                # query
    @args = qw( lmstat -a -c );      # cmd (query) arguments
    push @License::Manager, __PACKAGE__;

    sub _assign_servers {
        my $value = shift;
        @servers = ();

        if ($value) {
            my %index;
            my $index = 0;

            # get grouped server queries
            while ( $value =~ s/\{(.*?)\}// ) {
                if ($1) {
                    push @servers, $1;
                    $index++;
                }
            }

            for ( map { s{[:;]+}{ }g; split } $value ) {
                ( my $name = $_ ) =~ s/^\d*\@//;    ## port@server or @server
                if ( defined $index{$name} ) {
                    $servers[ $index{$name} ] .= ":$_";
                }
                else {
                    $index{$name} = $index++;
                    push @servers, $_;
                }
            }
        }
    }

    _assign_servers($env);
}

sub cmdname {
    return "lmutil";
}

sub envname {
    return "LM_LICENSE_FILE";
}

sub envvalue {
    return $env;
}

sub setcmd {
    my ( $caller, $value ) = @_;

    if ( defined $value ) {
        $cmd = $value;
    }
}

# setenv does not actually need to set the environment since we use
# the '-c' option directly
sub setenv {
    my ( $caller, $value ) = @_;

    if ( defined $value and ( not defined $env or $env ne $value ) ) {
        $env = $value;
        _assign_servers($value);
    }
}

# ------------------------------------------------------------------------------
# PARSE Flexlm output that looks like this
#
# License server status: port@server
#     License file(s) on server: ...
#
# Users of PATRAN:  (Total of 7 licenses available)
#
# "PATRAN" v2003.1130, vendor: MSC
# floating license
#
# user1 host1 host1 (v2002.0120) (server.domain/port 861), start Fri 1/31 11:00
# user2 host2 host2 (v2001.0523) (server.domain/port 1007), start Fri 1/31 12:24
# user3 host3 /dev/pts/0 (v1999.1020) (license.server.domain/port 352), start Fri 1/31 13:11
#
# ------------------------------------------------------------------------------
#
# Note that 'lmstat' also seems to use entries from the ~/.flexlmrc file and/or
# daemon-specific environment variables such as '*_LICENSE_FILE'.
#
# We thus limit the query to the entries explicitly found in LM_LICENSE_FILE
#
# return:
# HASHREF => {
#    feature => {
#       total  => number,
#       "user@machine nlicense" => occurances,
#       "user@machine nlicense" => occurances,
#    },
# }
sub query_server {
    my ( $caller, $server ) = @_;
    my $license = {};

    $server ||= join( ":" => @servers );

    my @lines = Shell->cmd( $cmd, @args, $server );

    defined $lines[0] or return $license;

    # warn "parse <@lines>\n";
    my ( $serverInfo, $feature );

    for (@lines) {
        defined or next;

        ## We don't currently do anything with this information
        ## capture server port/name
        #        if (/^License \s+ server \s+ status: \s+ (\d+\@\S+?)\s*$/mgcx)
        #         {
        #            $serverInfo = lc $1;
        #            next;
        #        }

        ## capture error status
        ## e.g. Users of DesignWare-Regression:  (Error: 10 licenses, unsupported by licensed server)
        if ( my ( $what, $total ) =
/^Users \s+ of \s+ (\S+?): .+? [Ee]rror:\s+ (\d+) \s+ licen[cs]e/mgcx
          )
        {
            $feature = $what;
            $license->{$feature} ||= { total => 0 };
            next;
        }

        ## extract total licenses available, record the 'feature' name
        if ( my ( $what, $total ) =
            /^Users \s+ of \s+ (\S+?): .+? \s+ (\d+) \s+ licen[cs]e/mgcx )
        {
            $feature = $what;
            $license->{$feature}{total} += $total;
            next;
        }

        $feature and exists $license->{$feature} or next;

        # lines with ", start" indicate a license is in use
        #
        # 'user' and 'machine' are the first 2 entries
        #
        if (/, \s+ start \s+/x) {
            my ($count) = /(\d+) \s+ licen[cs]e/x;
            $count ||= 1;

            my ( $user, $host ) = map { lc } split;
            $host =~ s/\..*$//;    # unqualified hostname

            $license->{$feature}{"$user\@$host $count"}++;
            next;
        }

        # add in queued licenses - identify with '*' prefix
        if ( my ($count) = /\s+ queued \s+ for  \s+ (\d+) \s+ licen[cs]es/x ) {
            my ( $user, $host ) = map { lc } split;
            $host =~ s/\..*$//;    # unqualified hostname

            $license->{$feature}{"*$user\@$host"} += $count || 1;
            next;
        }
    }

    return $license;
}

#
# spawn threads and merge results from multiple 'query_server' calls
#
# The optional remapping field can be used to rename features on a
# server-by-server basis before returning the hash. This only works when
# threading works correctly - ie, each query corresponds to exactly a
# single server
#
sub query {
    my $caller  = shift;
    my $mapFrom = shift || {};
    my $license = {};

    @servers or return $license;

    if ( @servers <= 1 and keys %$mapFrom ) {
        return $caller->query_server();
    }

    ## REMOVE REMAINDER FOR UNTHREADED PERL

    my @threads;    # record the server names / thread ids here
    for my $server (@servers) {
        my $thread = threads->create( sub { $caller->query_server($server) } );
        if ( defined $thread ) {
            my ( $lookup, %server );

            # group the servers, avoid touching the alias
            for ( map { s{[:;]+}{ }g; split } ( my $srv = $server ) ) {
                ( $lookup = $_ ) =~ s/^\d*\@//;    ## port@server or @server
                $lookup = lc $lookup;
                $server{$lookup}++;
            }

            keys %server == 1 or undef $lookup;
            push @threads, [ $lookup, $thread ];
        }
        else {
            warn "could not start thread for server $server\n;";
        }
    }

    # collect data, waiting for all threads to finish
    # each thread returns a hash-of-hashes
    for (@threads) {
        my ( $lookup, $thread ) = @$_;
        my ($hash) = $thread->join();

        # establish possible server-specific remapping
        my $remap = {};
        if ( defined $lookup and exists $mapFrom->{$lookup} ) {
            $remap = $mapFrom->{$lookup};
        }

        for ( keys %$hash ) {
            my $subhash = $hash->{$_};
            ## allow server-specific remapping
            my $feature = exists $remap->{$_} ? $remap->{$_} : $_;

            for my $k ( keys %$subhash ) {
                my $v = $subhash->{$k};
                $license->{$feature}{$k} += $v;
            }
        }
    }

    return $license;
}

1;

# --------------------------------------------------------------- end-of-package
# A class for combining several types of license managers.
# Assumes that the same license feature cannot be managed by more than a
# single license manager type

package License;

sub query {
    my $caller = shift;
    return +{ map { %{ $_->query(@_) } } @License::Manager };
}

sub envnames {
    my $caller = shift;
    return map { $_->envname() } @License::Manager;
}

1;

# --------------------------------------------------------------- end-of-package
# provide paths to GridEngine bin/ and utilbin/
# and wrappers to the Shell->cmd()

package GridEngine;
our ( $bin, $utilbin );

BEGIN {
    $ENV{SGE_SINGLE_LINE} = 1;    # do not break up long lines with backslashes

    $bin     = $ENV{SGE_BINARY_PATH} || '';
    $utilbin = $ENV{SGE_utilbin}     || '';

    if ( -d ( $ENV{SGE_ROOT} || '' ) ) {
        my $arch = $ENV{SGE_ARCH}
          || qx{$ENV{SGE_ROOT}/util/arch}
          || 'NONE';

        chomp $arch;

        -d $bin     or $bin     = "$ENV{SGE_ROOT}/bin/$arch";
        -d $utilbin or $utilbin = "$ENV{SGE_ROOT}/utilbin/$arch";
    }

    for ( $bin, $utilbin ) {
        if ( -d $_ ) {
            s{/*$}{/};
        }
        else {
            $_ = '';
        }
    }
}

# relay command to Shell
sub bin {
    my $caller = shift;
    my $cmd    = $bin . (shift);

    return Shell->cmd( $cmd, @_ );
}

# relay command to Shell
sub utilbin {
    my $caller = shift;
    my $cmd    = $utilbin . (shift);

    return Shell->cmd( $cmd, @_ );
}

# write readonly cache file,
# using temp file with rename to avoid race conditions
sub writeCache {
    my $caller    = shift;
    my $cacheFile = shift;

    defined $cacheFile and length $cacheFile and @_ or return;

    my $tmpFile = $cacheFile;
    if ( $cacheFile ne "-" ) {    # catch "-" STDOUT alias
        $tmpFile .= ".TMP";
        unlink $tmpFile;
    }
    local *FILE;
    open FILE, ">$tmpFile" or return;

    for (@_) {
        print FILE $_;
    }

    close FILE;                   # explicitly close before rename
    if ( $tmpFile ne $cacheFile ) {
        chmod 0444      => $tmpFile;      # output cache is readonly
        rename $tmpFile => $cacheFile;    # atomic
    }
}

# ------------------------------------------------------------------------------
# qhost query
#
# PARSE qhost xml output that looks like this:
#
# <?xml version='1.0'?>
# <qhost xmlns="http://gridengine.sunsource.net/61/qhost">
#  <host name='host.domain'>
#    <hostvalue name='arch_string'>lx26-amd64</hostvalue>
#    <hostvalue name='num_proc'>2</hostvalue>
#    <hostvalue name='load_avg'>0.09</hostvalue>
#    <hostvalue name='mem_total'>3.9G</hostvalue>
#    <hostvalue name='mem_used'>663.7M</hostvalue>
#    <hostvalue name='swap_total'>4.0G</hostvalue>
#    <hostvalue name='swap_used'>679.3M</hostvalue>
#  <queue name='desk'>
#    <queuevalue qname='desk' name='qtype_string'>BIP</queuevalue>
#    <queuevalue qname='desk' name='slots_used'>0</queuevalue>
#    <queuevalue qname='desk' name='slots'>1</queuevalue>
#    <queuevalue qname='desk' name='state_string'></queuevalue>
#  </queue>
#  <job name='52713'>
#    <jobvalue jobid='52713' name='priority'>'0.630035'</jobvalue>
#    <jobvalue jobid='52713' name='qinstance_name'>queue@host</jobvalue>
#    <jobvalue jobid='52713' name='job_name'>NAME</jobvalue>
#    <jobvalue jobid='52713' name='job_owner'>OWNER</jobvalue>
#    <jobvalue jobid='52713' name='job_state'>r</jobvalue>
#    <jobvalue jobid='52713' name='start_time'>1198055059</jobvalue>
#    <jobvalue jobid='52713' name='pe_master'>MASTER</jobvalue>
#  </job>
# </host>
# </qhost>
#
# fix xmlns=... with xmlns:xsd=...
# issue:
#   http://gridengine.sunsource.net/issues/show_bug.cgi?id=2515
#
sub qhost {
    my $caller    = shift;
    my $cacheFile = shift;

    # record qhost xml output to a file
    defined $cacheFile and length $cacheFile or return;

    my @args = qw( -q -j -xml );
    my $lines = GridEngine->bin( qhost => @args ) or return;

    # replace xmlns= with xmlns:xsd=
    # only needed for older GridEngine versions
    $lines =~ s{\s+xmlns=}{ xmlns:xsd=}s;

    # document the request without affecting the xml structure:
    # inject the query date and arguments as processing instructions
    # newer perl can use \K for a variable-length look behind
    my $date = POSIX::strftime( "%FT%T", localtime );
    $lines =~ s{^(<\?xml[^\?]+\?>)}{$1\n<?qhost date="$date"?>\n<?qhost command="@args"?>};

    GridEngine->writeCache( $cacheFile, $lines );
}

# ------------------------------------------------------------------------------
# PARSE qstat xml output that looks like this:
#
# <?xml version='1.0'?>
# <job_info  xmlns:xsd="http://www.w3.org/2001/XMLSchema">
#   <queue_info>
#     <job_list state="running">
#       <JB_job_number>934</JB_job_number>
#       <JAT_prio>0.56000</JAT_prio>
#       <JB_name>my_job_name</JB_name>
#       <JB_owner>user_name</JB_owner>
#       <state>r</state>
#       <JAT_start_time>11/30/2004 10:38:23</JAT_start_time>
#       <queue_name>cfd@host.domain</queue_name>
#       <slots>1</slots>
#       <hard_request name="license">1</hard_request>
#       <hard_req_queue>cfd</hard_req_queue>
#     </job_list>
#   </queue_info>
#   <job_info>
#   </job_info>
# </job_info>
# ------------------------------------------------------------------------------

# extract
#   * <JB_job_number> <JB_owner> <slots> <hard_request> <queue_name>
# return:
# HASHREF => {
#    complex => {
#       waiting => {
#          "*user" => count,
#       },
#       jobid => {
#          "user@machine nlicense" => occurances,
#          "user@machine nlicense" => occurances,
#       },
#    },
# }
#
sub qstat {
    my $caller      = shift;
    my $cacheFile   = shift;
    my $managedType = shift || {};
    my $status      = {};

    my @args = qw( -u * -xml -r -s prs );

    my $lines = GridEngine->bin( qstat => @args )
      or return $status;

    # optionally record qstat xml output to a file
    if ($cacheFile)
    {
        # document the request without affecting the xml structure:
        # inject the query date and arguments as processing instructions
        # newer perl can use \K for a variable-length look behind
        my $date = POSIX::strftime( "%FT%T", localtime );
        $lines =~ s{^(<\?xml[^\?]+\?>)}{$1\n<?qstat date="$date"?>\n<?qstat args="@args"?>};

        GridEngine->writeCache( $cacheFile, $lines );
    }

    my %re = (
        state => qr{<state>([A-Za-z]+)</state>},
        slots => qr{<slots>(\d+)</slots>},
        tasks => qr{<tasks>(\d+.*?)</tasks>},
        job   => qr{<JB_job_number>(.+?)</JB_job_number>},
        user  => qr{<JB_owner>(.+?)</JB_owner>},
        host  => qr{<queue_name>.+?\@(.+?)</queue_name>},
    );

    for ( grep { $_ } split m{</job_list>}, $lines ) {
        my ($state)    = /$re{state}/;
        my ($slots)    = /$re{slots}/ or last;
        my ($user)     = /$re{user}/ or last;
        my ($jobIdent) = /$re{job}/ or last;
        my ($host)     = /$re{host}/;
        my ($tasks)    = /$re{tasks}/;

        $tasks ||= 0;
        $jobIdent .= ".$tasks";

        ## waiting jobs/tasks
        if ( $state and $state =~ /[qw]/ ) {
            my $ntasks;
            if ($tasks) {
                my ( $min, $max, $step );

                # parse n[-m[:s]] and n,m
                # these should be the only possibilities
                if ( ( $min, $max, $step ) =
                    $tasks =~ /^(\d+)(?:-(\d+)(?::(\d+))?)?$/
                    or ( $min, $max ) = $tasks =~ /^(\d+),(\d+)?$/ )
                {
                    $max  ||= $min;
                    $step ||= 1;
                    for ( ; $min <= $max ; $min += $step ) {
                        $ntasks++;
                    }
                }
            }
            $ntasks ||= 1;

            while (
                s{<(\S*hard_request).*?\s+name=\"(\S+)\".*?>(\d[\.\d]*)</\1>}{})
            {
                my ( $name, $request ) = ( $2, $3 );

                ## scale non-'job' consumables
                $request *= $slots
                  unless exists $managedType->{$name}
                  and $managedType->{$name} =~ /job/i;

                my $count = sprintf "%.0f", ( $request * $ntasks );
                $status->{$name}{waiting}{$user} += $count;
            }
        }
        else {
            $host or next;    # safety
            $host =~ s{\..*$}{};    # strip domain - unqualified host name
            my $consumer = "\L$user\@$host";

            while (
                s{<(\S*hard_request).*?\s+name=\"(\S+)\".*?>(\d[\.\d]*)</\1>}{})
            {
                my ( $name, $request ) = ( $2, $3 );

                ## scale non-'job' consumables
                $request *= $slots
                  unless exists $managedType->{$name}
                  and $managedType->{$name} =~ /job/i;

                my $count = sprintf "%.0f", $request;
                $status->{$name}{$jobIdent}{"$consumer $count"}++;
            }
        }
    }

    return $status;
}

1;

# --------------------------------------------------------------- end-of-package
package Qconf;

BEGIN {
    $ENV{SGE_SINGLE_LINE} = 1;    # do not break up long lines with backslashes
}

# extract 'administrator_mail'

sub mail {
    my $caller = shift;

    my @lines = GridEngine->bin( qconf => qw( -sconf ) );
    defined $lines[0] or return undef;

    @lines = grep { s{^\s*administrator_mail\s+}{} } @lines;
    chomp @lines;

    return $lines[0];
}

# query 'complex_values' from the global host
# return hashref
sub query {
    my $caller = shift;

    my @lines = GridEngine->bin( qconf => qw( -se global ) );
    defined $lines[0] or return +{};

    return +{
        map {
            s/,/ /g;
            map { /^(.+)=(.+)\s*$/ } split;
          } grep { s/^\s*complex_values\s+// } @lines
    };
}

#
# set 'complex_values' of the global host
#
sub mattr {
    my $caller = shift;
    my $val    = shift;

    GridEngine->bin(
        qconf => ( qw( -mattr exechost complex_values ), $val, "global" ) )
      if $val;
}

# determine what exists in the globals and in complex_values and has changed
#
# Prototype ->diff( HASHREF1, HASHREF2 );
#
#
# HASHREF1 => {         # from the 'qconf -se global'
#    feature => total,
# }
#
# HASHREF2 => {         # from 'mungeLicenses'
#     feature => {
#        type => STRING or undef,
#        total => INT,
#        limit => INT,
#        extern => INT,
#        ...
#     }
# }
#
# determine the number of resources that can be managed by the GridEngine:
#   managed = total - external_count
#
sub diff {
    my $caller = shift;
    my ( $complex_values, $licenses ) = @_;
    my $changes = {};

    for my $resource ( keys %$complex_values ) {
        my $entry = $licenses->{$resource} or next;

        my ( $total, $limit, $extern ) = @{$entry}{qw( total limit extern )};
        my $managed = $total - $extern;
        if ( defined $limit and $limit < $managed ) {
            $managed = $limit;
        }

        $managed >= 0 or $managed = 0;    # should not be required

        $complex_values->{$resource} == $managed
          or $changes->{$resource} = $managed;
    }

    return $changes;
}

1;

# --------------------------------------------------------------- end-of-package

# ------------------------------------------------------------------ end-of-file