components/perl/sun_solaris/src/Sun/Solaris/Project/Project.pm

   1 #
   2 # Copyright (c) 1999, 2008, Oracle and/or its affiliates. All rights reserved.
   3 #
   4
   5 #
   6 # Project.pm provides the bootstrap for the Sun::Solaris::Project module, and
   7 # also functions for reading, validating and writing out project(4) format
   8 # files.
   9 #
  10 ################################################################################
  11 require 5.8.4;
  12
  13 use strict;
  14 use warnings;
  15 use locale;
  16 use Errno;
  17 use Fcntl;
  18 use File::Basename;
  19 use POSIX qw(locale_h limits_h);
  20
  21 package Sun::Solaris::Project;
  22
  23 our $VERSION = '1.9';
  24
  25 use XSLoader;
  26 XSLoader::load(__PACKAGE__, $VERSION);
  27
  28 our (@EXPORT_OK, %EXPORT_TAGS);
  29 my @constants = qw(MAXPROJID PROJNAME_MAX PROJF_PATH PROJECT_BUFSZ
  30     SETPROJ_ERR_TASK SETPROJ_ERR_POOL);
  31 my @syscalls = qw(getprojid);
  32 my @libcalls = qw(setproject activeprojects getprojent setprojent endprojent
  33     getprojbyname getprojbyid getdefaultproj fgetprojent inproj
  34     getprojidbyname);
  35 my @private = qw(projf_read projf_write projf_validate projent_parse
  36                  projent_parse_name projent_validate_unique_name
  37                  projent_parse_projid projent_validate_unique_id
  38                  projent_parse_comment
  39                  projent_parse_users
  40                  projent_parse_groups
  41                  projent_parse_attributes
  42                  projent_validate projent_validate_projid
  43                  projent_values_equal projent_values2string);
  44
  45 @EXPORT_OK = (@constants, @syscalls, @libcalls, @private);
  46 %EXPORT_TAGS = (CONSTANTS => \@constants, SYSCALLS => \@syscalls,
  47     LIBCALLS => \@libcalls, PRIVATE => \@private, ALL => \@EXPORT_OK);
  48
  49 use base qw(Exporter);
  50 use Sun::Solaris::Utils qw(gettext);
  51
  52 #
  53 # Set up default rules for validating rctls.
  54 # These rules are not global-flag specific, but instead
  55 # are the total set of allowable values on all rctls.
  56 #
  57 use Config;
  58 our $MaxNum = &RCTL_MAX_VALUE;
  59 our %RctlRules;
  60
  61 my %rules;
  62 our %SigNo;
  63 my $j;
  64 my $name;
  65 foreach $name (split(' ', $Config{sig_name})) {
  66         $SigNo{$name} = $j;
  67         $j++;
  68 }
  69 %rules = (
  70     'privs'     => [ qw(basic privileged priv) ],
  71     'actions'   => [ qw(none deny sig) ],
  72     'signals'   => [ qw(ABRT XRES HUP STOP TERM KILL XFSZ XCPU),
  73                      $SigNo{'ABRT'},
  74                      $SigNo{'XRES'},
  75                      $SigNo{'HUP'},
  76                      $SigNo{'STOP'},
  77                      $SigNo{'TERM'},
  78                      $SigNo{'KILL'},
  79                      $SigNo{'XFSZ'},
  80                      $SigNo{'XCPU'} ],
  81     'max'       => $MaxNum
  82 );
  83
  84 $RctlRules{'__DEFAULT__'} = \%rules;
  85
  86 #
  87 # projf_combine_errors(errorA, errorlistB)
  88 #
  89 # Concatenates a single error with a list of errors.  Each error in the new
  90 # list will have a status matching the status of errorA.
  91 #
  92 # Example:
  93 #
  94 #       projf_combine_errors(
  95 #           [ 5, "Error on line %d, 10 ],
  96 #           [ [ 3, "Invalid Value %s", "foo" ],
  97 #             [ 6, "Duplicate Value %s", "bar" ]
  98 #           ]);
  99 #
 100 # would return the list ref:
 101 #
 102 #       [ [ 5, "Error on line %d: Invalid Value %s", 10, "foo" ],
 103 #         [ 5, "Error on line %d: Duplicate Value %s", 10, "bar" ]
 104 #       ]
 105 #
 106 # This function is used when a fuction wants to add more information to
 107 # a list of errors returned by another function.
 108 #
 109 sub projf_combine_errors
 110 {
 111
 112         my ($error1, $errorlist)  = @_;
 113         my $error2;
 114
 115         my $newerror;
 116         my @newerrorlist;
 117
 118         my ($err1, $fmt1, @args1);
 119         my ($err2, $fmt2, @args2);
 120
 121         ($err1, $fmt1, @args1) = @$error1;
 122         foreach $error2 (@$errorlist) {
 123
 124                 ($err2, $fmt2, @args2) = @$error2;
 125                 $newerror = [ $err1, $fmt1 . ', ' . $fmt2, @args1, @args2];
 126                 push(@newerrorlist, $newerror);
 127         }
 128         return (\@newerrorlist);
 129 }
 130
 131 #
 132 # projf_read(filename, flags)
 133 #
 134 # Reads and parses a project(4) file, and returns a list of projent hashes.
 135 #
 136 # Inputs:
 137 #       filename - file to read
 138 #       flags    - hash ref of flags
 139 #
 140 # If flags contains key "validate", the project file entries will also be
 141 # validated for run-time correctness  If so, the flags ref is forwarded to
 142 # projf_validate().
 143 #
 144 # Return Value:
 145 #
 146 # Returns a ref to a list of projent hashes.  See projent_parse() for a
 147 # description of a projent hash.
 148 #
 149 sub projf_read
 150 {
 151
 152         my ($fh, $flags) = @_;
 153         my @projents;
 154         my $projent;
 155         my $linenum = 0;
 156         my ($projname, $projid, $comment, $users, $groups, $attributes);
 157         my ($ret, $ref);
 158         my @errs;
 159
 160         my ($line, $origline, $next, @projf);
 161         while (defined($line = <$fh>)) {
 162
 163                 $linenum++;
 164                 $origline = $line;
 165
 166                 # Remove any line continuations and trailing newline.
 167                 $line =~ s/\\\n//g;
 168                 chomp($line);
 169
 170
 171                 if (length($line) > (&PROJECT_BUFSZ - 2)) {
 172                         push(@errs,
 173                             [5,
 174                               gettext('Parse error on line %d, line too long'),
 175                             $linenum]);
 176
 177                 }
 178
 179                 ($ret, $ref) = projent_parse($line, {});
 180                 if ($ret != 0) {
 181                         $ref = projf_combine_errors(
 182                             [5, gettext('Parse error on line %d'), $linenum],
 183                             $ref);
 184                         push(@errs, @$ref);
 185                         next;
 186                 }
 187
 188                 $projent = $ref;
 189
 190                 #
 191                 # Cache original line to save original format if it is
 192                 # not changed.
 193                 #
 194                 $projent->{'line'} = $origline;
 195                 $projent->{'modified'} = 'false';
 196                 $projent->{'linenum'} = $linenum;
 197
 198                 push(@projents, $projent);
 199         }
 200
 201         if (defined($flags->{'validate'}) && ($flags->{'validate'} eq 'true')) {
 202                 ($ret, $ref) = projf_validate(\@projents, $flags);
 203                 if ($ret != 0) {
 204                         push(@errs, @$ref);
 205                 }
 206         }
 207
 208         if (@errs) {
 209                 return (1, \@errs);
 210
 211         } else {
 212                 return (0, \@projents);
 213         }
 214 }
 215
 216 #
 217 # projf_write(filehandle, projent list)
 218 #
 219 # Write a list of projent hashes to a file handle.
 220 # projent's with key "modified" => false will be
 221 # written using the "line" key.  projent's with
 222 # key "modified" => "true" will be written by
 223 # constructing a new line based on their "name"
 224 # "projid", "comment", "userlist", "grouplist"
 225 # and "attributelist" keys.
 226 #
 227 sub projf_write
 228 {
 229         my ($fh, $projents) = @_;
 230         my $projent;
 231         my $string;
 232
 233         foreach $projent (@$projents) {
 234
 235                 if ($projent->{'modified'} eq 'false') {
 236                         $string = $projent->{'line'};
 237                 } else {
 238                         $string = projent_2string($projent) . "\n";
 239                 }
 240                 print $fh "$string";
 241         }
 242 }
 243
 244 #
 245 # projent_parse(line)
 246 #
 247 # Functions for parsing the project file lines into projent hashes.
 248 #
 249 # Returns a number and a ref, one of:
 250 #
 251 #       (0, ref to projent hash)
 252 #       (non-zero, ref to list of errors)
 253 #
 254 #       Flag can be:
 255 #               allowspaces: allow spaces between user and group names.
 256 #               allowunits : allow units (K, M, etc), on rctl values.
 257 #
 258 # A projent hash contains the keys:
 259 #
 260 #       "name"          - string name of project
 261 #       "projid"        - numeric id of project
 262 #       "comment"       - comment string
 263 #       "users"         - , seperated user list string
 264 #       "userlist"      - list ref to list of user name strings
 265 #       "groups"        - , seperated group list string
 266 #       "grouplist"     - list ref to liset of group name strings
 267 #       "attributes"    - ; seperated attribute list string
 268 #       "attributelist" - list ref to list of attribute refs
 269 #                         (see projent_parse_attributes() for attribute ref)
 270 #
 271 sub projent_parse
 272 {
 273
 274         my ($line, $flags) = @_;
 275         my $projent = {};
 276         my ($ret, $ref);
 277         my @errs;
 278         my ($projname, $projid, $comment, $users, $groups, $attributes);
 279
 280         #
 281         # Split fields of project line.  split() is not used because
 282         # we must enforce that there are 6 fields.
 283         #
 284         ($projname, $projid, $comment, $users, $groups, $attributes) =
 285             $line =~
 286             /^([^:]*):([^:]*):([^:]*):([^:]*):([^:]*):([^:]*)$/;
 287
 288         # If there is not a complete match, nothing will be defined;
 289         if (!defined($projname)) {
 290                 push(@errs, [5, gettext(
 291                     'Incorrect number of fields.  Should have 5 ":"\'s.')]);
 292
 293                 # Get as many fields as we can.
 294                 ($projname, $projid, $comment, $users, $groups, $attributes) =
 295                     split(/:/, $line);
 296         }
 297
 298         if (defined($projname)) {
 299                 $projent->{'name'} = $projname;
 300                 ($ret, $ref) = projent_parse_name($projname);
 301                 if ($ret != 0) {
 302                         push(@errs, @$ref);
 303                 }
 304         }
 305         if (defined($projid)) {
 306                 $projent->{'projid'} = $projid;
 307                 ($ret, $ref) = projent_parse_projid($projid);
 308                 if ($ret != 0) {
 309                         push(@errs, @$ref);
 310                 }
 311         }
 312         if (defined($comment)) {
 313                 $projent->{'comment'} = $comment;
 314                 ($ret, $ref) = projent_parse_comment($comment);
 315                 if ($ret != 0) {
 316                         push(@errs, @$ref);
 317                 }
 318         }
 319         if (defined($users)) {
 320                 $projent->{'users'} = $users;
 321                 ($ret, $ref) = projent_parse_users($users, $flags);
 322                 if ($ret != 0) {
 323                         push(@errs, @$ref);
 324                 } else {
 325                         $projent->{'userlist'} = $ref;
 326                 }
 327         }
 328         if (defined($groups)) {
 329                 $projent->{'groups'} = $groups;
 330                 ($ret, $ref) = projent_parse_groups($groups, $flags);
 331                 if ($ret != 0) {
 332                         push(@errs, @$ref);
 333                 } else {
 334                         $projent->{'grouplist'} = $ref;
 335                 }
 336         }
 337         if (defined($attributes)) {
 338                 $projent->{'attributes'} = $attributes;
 339                 ($ret, $ref) = projent_parse_attributes($attributes, $flags);
 340                 if ($ret != 0) {
 341                         push(@errs, @$ref);
 342                 } else {
 343                         $projent->{'attributelist'} = $ref;
 344                 }
 345         }
 346
 347         if (@errs) {
 348                 return (1, \@errs);
 349
 350         } else {
 351                 return (0, $projent);
 352         }
 353 }
 354
 355 #
 356 # Project name syntax checking.
 357 #
 358 sub projent_parse_name
 359 {
 360         my @err;
 361         my ($projname) = @_;
 362
 363         if (!($projname =~ /^[[:alpha:]][[:alnum:]_.-]*$/)) {
 364                 push(@err, ([3, gettext(
 365                     'Invalid project name "%s", contains invalid characters'),
 366                     $projname]));
 367                 return (1, \@err);
 368         }
 369         if (length($projname) > &PROJNAME_MAX) {
 370                 push(@err, ([3, gettext(
 371                     'Invalid project name "%s", name too long'),
 372                     $projname]));
 373                 return (1, \@err);
 374         }
 375         return (0, $projname);
 376 }
 377
 378 #
 379 # Projid syntax checking.
 380 #
 381 sub projent_parse_projid
 382 {
 383         my @err;
 384         my ($projid) = @_;
 385
 386         # verify projid is a positive number, and less than UID_MAX
 387         if (!($projid =~ /^\d+$/)) {
 388                 push(@err, [3, gettext('Invalid projid "%s"'),
 389                     $projid]);
 390                 return (1, \@err);
 391
 392         } elsif ($projid > POSIX::INT_MAX) {
 393                 push(@err, [3, gettext('Invalid projid "%s": must be <= '.
 394                     POSIX::INT_MAX),
 395                     $projid]);
 396                 return (1, \@err);
 397
 398         } else {
 399                 return (0, $projid);
 400         }
 401 }
 402
 403 #
 404 # Project comment syntax checking.
 405 #
 406 sub projent_parse_comment
 407 {
 408         my ($comment) = @_;
 409
 410         # no restrictions on comments
 411         return (0, $comment);
 412 }
 413
 414 #
 415 # projent_parse_users(string, flags)
 416 #
 417 # Parses "," seperated list of users, and returns list ref to a list of
 418 # user names.  If flags contains key "allowspaces", then spaces are
 419 # allowed between user names and ","'s.
 420 #
 421 sub projent_parse_users
 422 {
 423         my ($users, $flags) = @_;
 424         my @err;
 425         my $user;
 426         my $pattern;
 427         my @userlist;
 428
 429         if (exists($flags->{'allowspaces'})) {
 430                 $pattern = '\s*,\s*';
 431         } else {
 432                 $pattern = ',';
 433         }
 434         @userlist = split(/$pattern/, $users);
 435
 436         # Return empty list if there are no users.
 437         if (!(@userlist)) {
 438                 return (0, \@userlist);
 439         }
 440
 441         # Verify each user name is the correct format for a valid user name.
 442         foreach $user (@userlist) {
 443
 444                 # Allow for wildcards.
 445                 if ($user eq '*' || $user eq '!*') {
 446                         next;
 447                 }
 448
 449                 # Allow for ! operator, usernames must begin with alpha-num,
 450                 # and contain alpha-num, '_', digits, '.', or '-'.
 451                 if (!($user =~ /^!?[[:alpha:]][[:alnum:]_.-]*$/)) {
 452                         push(@err, [3, gettext('Invalid user name "%s"'),
 453                             $user]);
 454                         next;
 455                 }
 456         }
 457         if (@err) {
 458                 return (1,\ @err);
 459         } else {
 460                 return (0, \@userlist);
 461         }
 462 }
 463
 464 #
 465 # projent_parse_groups(string, flags)
 466 #
 467 # Parses "," seperated list of groups, and returns list ref to a list of
 468 # groups names.  If flags contains key "allowspaces", then spaces are
 469 # allowed between group names and ","'s.
 470 #
 471 sub projent_parse_groups
 472 {
 473         my ($groups, $flags) = @_;
 474         my @err;
 475         my $group;
 476         my $pattern;
 477
 478         my @grouplist;
 479
 480         if (exists($flags->{'allowspaces'})) {
 481                 $pattern = '\s*,\s*';
 482         } else {
 483                 $pattern = ',';
 484         }
 485         @grouplist = split(/$pattern/, $groups);
 486
 487         # Return empty list if there are no groups.
 488         if (!(@grouplist)) {
 489                 return (0, \@grouplist);
 490         }
 491
 492         # Verify each group is the correct format for a valid group name.
 493         foreach $group (@grouplist) {
 494
 495                 # Allow for wildcards.
 496                 if ($group eq '*' || $group eq '!*') {
 497                         next;
 498                 }
 499
 500                 # Allow for ! operator, groupnames can contain only alpha
 501                 # characters and digits.
 502                 if (!($group =~ /^!?[[:alnum:]]+$/)) {
 503                         push(@err, [3, gettext('Invalid group name "%s"'),
 504                             $group]);
 505                         next;
 506                 }
 507         }
 508
 509         if (@err) {
 510                 return (1,\ @err);
 511         } else {
 512                 return (0, \@grouplist);
 513         }
 514 }
 515
 516 #
 517 # projent_tokenize_attribute_values(values)
 518 #
 519 # Values is the right hand side of a name=values attribute/values pair.
 520 # This function splits the values string into a list of tokens.  Tokens are
 521 # valid string values and the characters ( ) ,
 522 #
 523 sub projent_tokenize_attribute_values
 524 {
 525         #
 526         # This seperates the attribute string into higher level tokens
 527         # for parsing.
 528         #
 529         my $prev;
 530         my $cur;
 531         my $next;
 532         my $token;
 533         my @tokens;
 534         my @newtokens;
 535         my @err;
 536
 537         # Seperate tokens delimited by "(", ")", and ",".
 538         @tokens = split(/([,()])/, $_[0], -1);
 539
 540         # Get rid of blanks
 541         @newtokens = grep($_ ne '', @tokens);
 542
 543         foreach $token (@newtokens) {
 544                 if (!($token =~ /^[(),]$/ ||
 545                       $token =~ /^[[:alnum:]_.\/=+-]*$/)) {
 546                         push(@err, [3, gettext(
 547                             'Invalid Character at or near "%s"'), $token]);
 548                 }
 549         }
 550         if (@err) {
 551                 return (1, \@err);
 552         } else {
 553                 return (0, \@newtokens);
 554         }
 555 }
 556
 557 #
 558 # projent_parse_attribute_values(values)
 559 #
 560 # Values is the right hand side of a name=values attribute/values pair.
 561 # This function parses the values string into a list of values.  Each value
 562 # can be either a scalar value, or a ref to another list of values.
 563 # A ref to the list of values is returned.
 564 #
 565 sub projent_parse_attribute_values
 566 {
 567         #
 568         # For some reason attribute values can be lists of values and
 569         # sublists, which are scoped using ()'s.  All values and sublists
 570         # are delimited by ","'s.  Empty values are lists are permitted.
 571
 572         # This function returns a reference to a list of values, each of
 573         # which can be a scalar value, or a reference to a sublist.  Sublists
 574         # can contain both scalar values and references to furthur sublists.
 575         #
 576         my ($values) = @_;
 577         my $tokens;
 578         my @usedtokens;
 579         my $token;
 580         my $prev = '';
 581         my $parendepth = 0;
 582         my @valuestack;
 583         my @err;
 584         my ($ret, $ref);
 585         my $line;
 586
 587         push (@valuestack, []);
 588
 589         ($ret, $ref) = projent_tokenize_attribute_values($values);
 590         if ($ret != 0) {
 591                 return ($ret, $ref);
 592         }
 593         $tokens = $ref;
 594
 595         foreach $token (@$tokens) {
 596
 597                 push(@usedtokens, $token);
 598
 599                 if ($token eq ',') {
 600
 601                         if ($prev eq ',' || $prev eq '(' ||
 602                             $prev eq '') {
 603                                 push(@{$valuestack[$#valuestack]}, '');
 604                         }
 605                         $prev = ',';
 606                         next;
 607                 }
 608                 if ($token eq '(') {
 609
 610                         if (!($prev eq '(' || $prev eq ',' ||
 611                               $prev eq '')) {
 612
 613                                 $line = join('', @usedtokens);
 614                                 push(@err, [3, gettext(
 615                                     '"%s" <- "(" unexpected'),
 616                                     $line]);
 617
 618                                 return (1, \@err);
 619                         }
 620
 621                         $parendepth++;
 622                         my $arrayref = [];
 623                         push(@{$valuestack[$#valuestack]}, $arrayref);
 624                         push(@valuestack, $arrayref);
 625
 626                         $prev = '(';
 627                         next;
 628                 }
 629                 if ($token eq ')') {
 630
 631                         if ($parendepth <= 0) {
 632
 633                                 $line = join('', @usedtokens);
 634                                 push(@err, [3, gettext(
 635                                     '"%s" <- ")" unexpected'),
 636                                     $line]);
 637
 638                                 return (1, \@err);
 639                         }
 640
 641                         if ($prev eq ',' || $prev eq '(') {
 642                                 push(@{$valuestack[$#valuestack]}, '');
 643                         }
 644                         $parendepth--;
 645                         pop @valuestack;
 646
 647                         $prev = ')';
 648                         next;
 649                 }
 650
 651                 if (!($prev eq ',' || $prev eq '(' || $prev eq '')) {
 652                         $line = join('', @usedtokens);
 653                         push(@err, [3, gettext(
 654                             '"%s" <- "%s" unexpected'),
 655                             $line, $token]);
 656
 657                         return (1, \@err);
 658                 }
 659
 660                 push(@{$valuestack[$#valuestack]}, $token);
 661                 $prev = $token;
 662                 next;
 663         }
 664
 665         if ($parendepth != 0) {
 666                 push(@err, [3, gettext(
 667                     '"%s" <- ")" missing'),
 668                     $values]);
 669                 return (1, \@err);
 670         }
 671
 672         if ($prev eq ',' || $prev eq '') {
 673                 push(@{$valuestack[$#valuestack]}, '');
 674         }
 675
 676         return (0, $valuestack[0]);
 677 }
 678
 679 #
 680 # projent_parse_attribute("name=values", $flags)
 681 #
 682 # $flags is a hash ref.
 683 # Valid flags keys:
 684 #       'allowunits' - allows numeric values to be scaled on certain attributes
 685 #
 686 # Returns a hash ref with keys:
 687 #
 688 #       "name"          - name of attribute
 689 #       "values"        - ref to list of values.
 690 #                         Each value can be a scalar value, or a ref to
 691 #                         a sub-list of values.
 692 #
 693 sub projent_parse_attribute
 694 {
 695         my ($string, $flags) = @_;
 696         my $attribute = {};
 697         my ($name, $stock, $values);
 698         my ($ret, $ref);
 699         my @err;
 700         my $scale;
 701         my $num;
 702         my $modifier;
 703         my $unit;
 704         my $tuple;
 705         my $rules;
 706         my $rctlmax;
 707         my $rctlflags;
 708
 709         # pattern for matching stock symbols.
 710         my $stockp = '[[:upper:]]{1,5}(?:.[[:upper:]]{1,5})?,';
 711         # Match attribute with no value.
 712         ($name, $stock) = $string =~
 713             /^(($stockp)?[[:alpha:]][[:alnum:]_.-]*)$/;
 714         if ($name) {
 715                 $attribute->{'name'} = $name;
 716                 return (0, $attribute);
 717         }
 718
 719         # Match attribute with value list.
 720         ($name, $stock, $values) = $string =~
 721             /^(($stockp)?[[:alpha:]][[:alnum:]_.-]*)=(.*)$/;
 722         if ($name) {
 723                 $attribute->{'name'} = $name;
 724
 725                 if (!defined($values)) {
 726                         $values = '';
 727                 }
 728
 729                 ($ret, $ref) = projent_parse_attribute_values($values);
 730                 if ($ret != 0) {
 731                         $ref = projf_combine_errors(
 732                             [3,
 733                             gettext('Invalid value on attribute "%s"'),
 734                             $name], $ref);
 735                         push(@err, @$ref);
 736                         return ($ret, \@err)
 737                 }
 738
 739                 # Scale attributes than can be scaled.
 740                 if (exists($flags->{"allowunits"})) {
 741
 742                         if ($name eq 'rcap.max-rss' &&
 743                             defined($ref->[0]) && !ref($ref->[0])) {
 744                                 $scale = 'bytes';
 745
 746                                 ($num, $modifier, $unit) =
 747                                     projent_val2num($ref->[0], $scale);
 748
 749                                 if (!defined($num)) {
 750
 751                                         if (defined($unit)) {
 752                                                 push(@err, [3, gettext(
 753                                                     'rcap.max-rss has invalid '.
 754                                                     'unit "%s"'), $unit]);
 755                                         } else {
 756                                                 push(@err, [3, gettext(
 757                                                     'rcap.max-rss has invalid '.
 758                                                     'value "%s"'), $ref->[0]]);
 759                                         }
 760                                 } elsif ($num eq "OVERFLOW") {
 761                                         push(@err, [3, gettext( 'rcap.max-rss value '.
 762                                             '"%s" exceeds maximum value "%s"'),
 763                                             $ref->[0], $MaxNum]);
 764                                 } else {
 765                                         $ref->[0] = $num;
 766                                 }
 767                         }
 768                         # Check hashed cache of rctl rules.
 769                         $rules = $RctlRules{$name};
 770                         if (!defined($rules)) {
 771                                 #
 772                                 # See if this is an resource control name, if so
 773                                 # cache rules.
 774                                 #
 775                                 ($rctlmax, $rctlflags) = rctl_get_info($name);
 776                                 if (defined($rctlmax)) {
 777                                         $rules = proj_getrctlrules(
 778                                             $rctlmax, $rctlflags);
 779                                         if (defined($rules)) {
 780                                                 $RctlRules{$name} = $rules;
 781                                         } else {
 782                                                 $RctlRules{$name} =
 783                                                     "NOT AN RCTL";
 784                                         }
 785                                 }
 786                         }
 787
 788                         # Scale values if this is an rctl.
 789                         if (defined ($rules) && ref($rules)) {
 790                                 $flags->{'type'} = $rules->{'type'};
 791                                 foreach $tuple (@$ref) {
 792
 793                                         # Skip if tuple this is not a list.
 794                                         if (!ref($tuple)) {
 795                                                 next;
 796                                         }
 797                                         # Skip if second element is not scalar.
 798                                         if (!defined($tuple->[1]) ||
 799                                              ref($tuple->[1])) {
 800                                                 next;
 801                                         }
 802                                         ($num, $modifier, $unit) =
 803                                             projent_val2num($tuple->[1],
 804                                                 $flags->{'type'});
 805
 806                                         if (!defined($num)) {
 807
 808                                                 if (defined($unit)) {
 809                                                         push(@err, [3, gettext(
 810                                                             'rctl %s has '.
 811                                                             'invalid unit '.
 812                                                             '"%s"'),$name,
 813                                                             $unit]);
 814                                                 } else {
 815                                                         push(@err, [3, gettext(
 816                                                             'rctl %s has '.
 817                                                             'invalid value '.
 818                                                             '"%s"'), $name,
 819                                                             $tuple->[1]]);
 820                                                 }
 821                                         } elsif ($num eq "OVERFLOW") {
 822                                                 push(@err, [3, gettext(
 823                                                     'rctl %s value "%s" '.
 824                                                     'exceeds maximum value "%s"'),
 825                                                      $name, $tuple->[1], $MaxNum]);
 826                                         } else {
 827                                                 $tuple->[1] = $num;
 828                                         }
 829                                 }
 830                         }
 831                 }
 832                 $attribute->{'values'} = $ref;
 833                 if (@err) {
 834                         return (1, \@err);
 835                 } else {
 836                         return (0, $attribute);
 837                 }
 838
 839         } else {
 840                 # Attribute did not match name[=value,value...]
 841                 push(@err, [3, gettext('Invalid attribute "%s"'), $string]);
 842                 return (1, \@err);
 843         }
 844 }
 845
 846 #
 847 # projent_parse_attributes("; seperated list of name=values pairs");
 848 #
 849 # Returns a list of attribute references, as returned by
 850 # projent_parse_attribute().
 851 #
 852 sub projent_parse_attributes
 853 {
 854         my ($attributes, $flags) = @_;
 855         my @attributelist;
 856         my @attributestrings;
 857         my $attributestring;
 858         my $attribute;
 859         my ($ret, $ref);
 860         my @errs;
 861
 862         # Split up attributes by ";"'s.
 863         @attributestrings = split(/;/, $attributes);
 864
 865         # If no attributes, return empty list.
 866         if (!@attributestrings) {
 867                 return (0, \@attributelist);
 868         }
 869
 870         foreach $attributestring (@attributestrings) {
 871
 872                 ($ret, $ref) = projent_parse_attribute($attributestring,
 873                     $flags);
 874                 if ($ret != 0) {
 875                         push(@errs, @$ref);
 876                 } else {
 877                         push(@attributelist, $ref);
 878                 }
 879         }
 880
 881         if (@errs) {
 882                 return (1, \@errs);
 883         } else {
 884                 return (0, \@attributelist);
 885         }
 886
 887 }
 888
 889 #
 890 # projent_values_equal(list A, list B)
 891 #
 892 # Given two references to lists of attribute values (as returned by
 893 # projent_parse_attribute_values()), returns 1 if they are identical
 894 # lists or 0 if they are not.
 895 #
 896 # XXX sub projent_values_equal;
 897 sub projent_values_equal
 898 {
 899         my ($x, $y) = @_;
 900
 901         my $itema;
 902         my $itemb;
 903         my $index = 0;
 904
 905         if (ref($x) && ref($y)) {
 906
 907                 if (scalar(@$x) != scalar(@$y)) {
 908                         return (0);
 909                 } else {
 910                         foreach $itema (@$x) {
 911
 912                                 $itemb = $y->[$index++];
 913
 914                                 if (!projent_values_equal($itema, $itemb)) {
 915                                         return (0);
 916                                 }
 917                         }
 918                         return (1);
 919                 }
 920         } elsif ((!ref($x) && (!ref($y)))) {
 921                 return ($x eq $y);
 922         } else {
 923                 return (0);
 924         }
 925 }
 926
 927 #
 928 # Converts a list of values to a , seperated string, enclosing sublists
 929 # in ()'s.
 930 #
 931 sub projent_values2string
 932 {
 933         my ($values) = @_;
 934         my $string;
 935         my $value;
 936         my @valuelist;
 937
 938         if (!defined($values)) {
 939                 return ('');
 940         }
 941         if (!ref($values)) {
 942                 return ($values);
 943         }
 944         foreach $value (@$values) {
 945
 946                 if (ref($value)) {
 947                         push(@valuelist,
 948                             '(' . projent_values2string($value) . ')');
 949                 } else {
 950                         push(@valuelist, $value);
 951                 }
 952         }
 953
 954         $string = join(',', @valuelist) ;
 955         if (!defined($string)) {
 956                 $string = '';
 957         }
 958         return ($string);
 959 }
 960
 961 #
 962 # Converts a ref to an attribute hash with keys "name", and "values" to
 963 # a string in the form "name=value,value...".
 964 #
 965 sub projent_attribute2string
 966 {
 967         my ($attribute) = @_;
 968         my $string;
 969
 970         $string = $attribute->{'name'};
 971
 972         if (ref($attribute->{'values'}) && @{$attribute->{'values'}}) {
 973                 $string = $string . '=' .
 974                     projent_values2string(($attribute->{'values'}));
 975         }
 976         return ($string);
 977 }
 978
 979 #
 980 # Converts a ref to a projent hash (as returned by projent_parse()) to
 981 # a project(4) database entry line.
 982 #
 983 sub projent_2string
 984 {
 985         my ($projent) = @_;
 986         my @attributestrings;
 987         my $attribute;
 988
 989         foreach $attribute (@{$projent->{'attributelist'}}) {
 990                 push(@attributestrings, projent_attribute2string($attribute));
 991         }
 992         return (join(':', ($projent->{'name'},
 993                            $projent->{'projid'},
 994                            $projent->{'comment'},
 995                            join(',', @{$projent->{'userlist'}}),
 996                            join(',', @{$projent->{'grouplist'}}),
 997                            join(';', @attributestrings))));
 998 }
 999
1000 #
1001 # projf_validate(ref to list of projents hashes, flags)
1002 #
1003 # For each projent hash ref in the list, checks that users, groups, and pools
1004 # exists, and that known attributes are valid.  Attributes matching rctl names
1005 # are verified to have valid values given that rctl's global flags and max
1006 # value.
1007 #
1008 # Valid flag keys:
1009 #
1010 #       "res"   - allow reserved project ids 0-99
1011 #       "dup"   - allow duplicate project ids
1012 #
1013 sub projf_validate
1014 {
1015         my ($projents, $flags) = @_;
1016         my $projent;
1017         my $ret;
1018         my $ref;
1019         my @err;
1020         my %idhash;
1021         my %namehash;
1022         my %seenids;
1023         my %seennames;
1024
1025         # check for unique project names
1026         foreach $projent (@$projents) {
1027
1028                 my @lineerr;
1029
1030                 $seennames{$projent->{'name'}}++;
1031                 $seenids{$projent->{'projid'}}++;
1032
1033                 if ($seennames{$projent->{'name'}} > 1) {
1034                         push(@lineerr, [4, gettext(
1035                             'Duplicate project name "%s"'),
1036                             $projent->{'name'}]);
1037                 }
1038
1039                 if (!defined($flags->{'dup'})) {
1040                         if ($seenids{$projent->{'projid'}} > 1) {
1041                                 push(@lineerr, [4, gettext(
1042                                     'Duplicate projid "%s"'),
1043                                     $projent->{'projid'}]);
1044                         }
1045                 }
1046                 ($ret, $ref) = projent_validate($projent, $flags);
1047                 if ($ret != 0) {
1048                         push(@lineerr, @$ref);
1049                 }
1050
1051                 if (@lineerr) {
1052
1053                         $ref = projf_combine_errors([5, gettext(
1054                             'Validation error on line %d'),
1055                             $projent->{'linenum'}], \@lineerr);
1056                         push(@err, @$ref);
1057                 }
1058         }
1059         if (@err) {
1060                 return (1, \@err);
1061         } else {
1062                 return (0, $projents);
1063         }
1064 }
1065
1066 #
1067 # projent_validate_unique_id(
1068 #     ref to projent hash, ref to list of projent hashes)
1069 #
1070 # Verifies that projid of the projent hash only exists once in the list of
1071 # projent hashes.
1072 #
1073 sub projent_validate_unique_id
1074 {
1075         my ($projent, $projf, $idhash) = @_;
1076         my @err;
1077         my $ret = 0;
1078         my $projid = $projent->{'projid'};
1079
1080         if (scalar(grep($_->{'projid'} eq $projid, @$projf)) > 1) {
1081                 $ret = 1;
1082                 push(@err, [4, gettext('Duplicate projid "%s"'),
1083                     $projid]);
1084         }
1085
1086         return ($ret, \@err);
1087 }
1088
1089 #
1090 # projent_validate_unique_id(
1091 #     ref to projent hash, ref to list of projent hashes)
1092 #
1093 # Verifies that project name of the projent hash only exists once in the list
1094 # of projent hashes.
1095 #
1096 # If the seconds argument is a hash ref, it is treated
1097 #
1098 sub projent_validate_unique_name
1099 {
1100         my ($projent, $projf, $namehash) = @_;
1101         my $ret = 0;
1102         my @err;
1103         my $pname = $projent->{'name'};
1104
1105         if (scalar(grep($_->{'name'} eq $pname, @$projf)) > 1) {
1106                 $ret = 1;
1107                 push(@err,
1108                      [9, gettext('Duplicate project name "%s"'), $pname]);
1109         }
1110
1111         return ($ret, \@err);
1112 }
1113
1114 #
1115 # projent_validate(ref to projents hash, flags)
1116 #
1117 # Checks that users, groups, and pools exists, and that known attributes
1118 # are valid.  Attributes matching rctl names are verified to have valid
1119 # values given that rctl's global flags and max value.
1120 #
1121 # Valid flag keys:
1122 #
1123 #       "allowspaces"   - user and group list are allowed to contain whitespace
1124 #       "res"           - allow reserved project ids 0-99
1125 #
1126 sub projent_validate
1127 {
1128         my ($projent, $flags) = @_;
1129         my $ret = 0;
1130         my $ref;
1131         my @err;
1132
1133         ($ret, $ref) =
1134             projent_validate_name($projent->{'name'}, $flags);
1135         if ($ret != 0) {
1136                 push(@err, @$ref);
1137         }
1138         ($ret, $ref) =
1139             projent_validate_projid($projent->{'projid'}, $flags);
1140         if ($ret != 0) {
1141                 push(@err, @$ref);
1142         }
1143         ($ret, $ref) =
1144             projent_validate_comment($projent->{'comment'}, $flags);
1145         if ($ret != 0) {
1146                 push(@err, @$ref);
1147         }
1148         ($ret, $ref) =
1149             projent_validate_users($projent->{'userlist'}, $flags);
1150         if ($ret != 0) {
1151                 push(@err, @$ref);
1152         }
1153         ($ret, $ref) =
1154             projent_validate_groups($projent->{'grouplist'}, $flags);
1155         if ($ret != 0) {
1156                 push(@err, @$ref);
1157         }
1158         ($ret, $ref) = projent_validate_attributes(
1159             $projent->{'attributelist'}, $flags);
1160         if ($ret != 0) {
1161                 push(@err, @$ref);
1162         }
1163
1164         my $string = projent_2string($projent);
1165         if (length($string) > (&PROJECT_BUFSZ - 2)) {
1166                 push(@err, [3, gettext('projent line too long')]);
1167         }
1168
1169         if (@err) {
1170                 return (1, \@err);
1171         } else {
1172                 return (0, $projent);
1173         }
1174 }
1175
1176 #
1177 # projent_validate_name(name, flags)
1178 #
1179 # does nothing, as any parse-able project name is valid
1180 #
1181 sub projent_validate_name
1182 {
1183         my ($name, $flags) = @_;
1184         my @err;
1185
1186         return (0, \@err);
1187
1188 }
1189
1190 #
1191 # projent_validate_projid(projid, flags)
1192 #
1193 # Validates that projid is within the valid range of numbers.
1194 # Valid flag keys:
1195 #       "res"   - allow reserved projid's 0-99
1196 #
1197 sub projent_validate_projid
1198 {
1199         my ($projid, $flags) = @_;
1200         my @err;
1201         my $ret = 0;
1202         my $minprojid;
1203
1204         if (defined($flags->{'res'})) {
1205                 $minprojid = 0;
1206         } else {
1207                 $minprojid = 100;
1208         }
1209
1210         if ($projid < $minprojid) {
1211
1212                 $ret = 1;
1213                 push(@err, [3, gettext('Invalid projid "%s": '.
1214                     'must be >= 100'),
1215                     $projid]);
1216
1217         }
1218
1219         return ($ret, \@err);
1220 }
1221
1222 #
1223 # projent_validate_comment(name, flags)
1224 #
1225 # Does nothing, as any parse-able comment is valid.
1226 #
1227 sub projent_validate_comment
1228 {
1229         my ($comment, $flags) = @_;
1230         my @err;
1231
1232         return (0, \@err);
1233 }
1234
1235 #
1236 # projent_validate_users(ref to list of user names, flags)
1237 #
1238 # Verifies that each username is either a valid glob, such
1239 # as * or !*, or is an existing user.  flags is unused.
1240 # Also validates that there are no duplicates.
1241 #
1242 sub projent_validate_users
1243 {
1244         my ($users, $flags) = @_;
1245         my @err;
1246         my $ret = 0;
1247         my $user;
1248         my $username;
1249
1250         foreach $user (@$users) {
1251
1252                 if ($user eq '*' || $user eq '!*') {
1253                         next;
1254                 }
1255                 $username = $user;
1256                 $username =~ s/^!//;
1257
1258                 if (!defined(getpwnam($username))) {
1259                         $ret = 1;
1260                         push(@err, [6,
1261                             gettext('User "%s" does not exist'),
1262                             $username]);
1263                 }
1264         }
1265
1266         my %seen;
1267         my @dups = grep($seen{$_}++ == 1, @$users);
1268         if (@dups) {
1269                 $ret = 1;
1270                 push(@err, [3, gettext('Duplicate user names "%s"'),
1271                     join(',', @dups)]);
1272         }
1273         return ($ret, \@err)
1274 }
1275
1276 #
1277 # projent_validate_groups(ref to list of group names, flags)
1278 #
1279 # Verifies that each groupname is either a valid glob, such
1280 # as * or !*, or is an existing group.  flags is unused.
1281 # Also validates that there are no duplicates.
1282 #
1283 sub projent_validate_groups
1284 {
1285         my ($groups, $flags) = @_;
1286         my @err;
1287         my $ret = 0;
1288         my $group;
1289         my $groupname;
1290
1291         foreach $group (@$groups) {
1292
1293                 if ($group eq '*' || $group eq '!*') {
1294                         next;
1295                 }
1296
1297                 $groupname = $group;
1298                 $groupname =~ s/^!//;
1299
1300                 if (!defined(getgrnam($groupname))) {
1301                         $ret = 1;
1302                         push(@err, [6,
1303                             gettext('Group "%s" does not exist'),
1304                             $groupname]);
1305                 }
1306         }
1307
1308         my %seen;
1309         my @dups = grep($seen{$_}++ == 1, @$groups);
1310         if (@dups) {
1311                 $ret = 1;
1312                 push(@err, [3, gettext('Duplicate group names "%s"'),
1313                     join(',', @dups)]);
1314         }
1315
1316         return ($ret, \@err)
1317 }
1318
1319 #
1320 # projent_validate_attribute(attribute hash ref, flags)
1321 #
1322 # Verifies that if the attribute's name is a known attribute or
1323 # resource control, that it contains a valid value.
1324 # flags is unused.
1325 #
1326 sub projent_validate_attribute
1327 {
1328         my ($attribute, $flags) = @_;
1329         my $name = $attribute->{'name'};
1330         my $values = $attribute->{'values'};
1331         my $value;
1332         my @errs;
1333         my $ret = 0;
1334         my $result;
1335         my $ref;
1336
1337         if (defined($values)) {
1338                 $value = $values->[0];
1339         }
1340         if ($name eq 'task.final') {
1341
1342                 if (defined($values)) {
1343                         $ret = 1;
1344                         push(@errs, [3, gettext(
1345                             'task.final should not have value')]);
1346                 }
1347
1348         # Need to rcap.max-rss needs to be a number
1349         } elsif ($name eq 'rcap.max-rss') {
1350
1351                 if (!defined($values)) {
1352                         $ret = 1;
1353                         push(@errs, [3, gettext(
1354                             'rcap.max-rss missing value')]);
1355                 } elsif (scalar(@$values) != 1) {
1356                         $ret = 1;
1357                         push(@errs, [3, gettext(
1358                             'rcap.max-rss should have single value')]);
1359                 }
1360                 if (!defined($value) || ref($value)) {
1361                         $ret = 1;
1362                         push(@errs, [3, gettext(
1363                             'rcap.max-rss has invalid value "%s"'),
1364                             projent_values2string($values)]);;
1365                 } elsif ($value !~ /^\d+$/) {
1366                         $ret = 1;
1367                         push(@errs, [3, gettext(
1368                             'rcap.max-rss is not an integer value: "%s"'),
1369                             projent_values2string($values)]);;
1370                 } elsif ($value > $MaxNum) {
1371                         $ret = 1;
1372                         push(@errs, [3, gettext(
1373                             'rcap.max-rss too large')]);
1374                 }
1375
1376         } elsif ($name eq 'project.pool') {
1377                 if (!defined($values)) {
1378                         $ret = 1;
1379                         push(@errs, [3, gettext(
1380                             'project.pool missing value')]);
1381                 } elsif (scalar(@$values) != 1) {
1382                         $ret = 1;
1383                         push(@errs, [3, gettext(
1384                             'project.pool should have single value')]);
1385                 } elsif (!defined($value) || ref($value)) {
1386                         $ret = 1;
1387                         push(@errs, [3, gettext(
1388                             'project.pool has invalid value "%s'),
1389                             projent_values2string($values)]);;
1390                 } elsif (!($value =~ /^[[:alpha:]][[:alnum:]_.-]*$/)) {
1391                         $ret = 1;
1392                         push(@errs, [3, gettext(
1393                             'project.pool: invalid pool name "%s"'),
1394                             $value]);
1395                 # Pool must exist.
1396                 } elsif (pool_exists($value) != 0) {
1397                         $ret = 1;
1398                         push(@errs, [6, gettext(
1399                             'project.pool: pools not enabled or pool does '.
1400                             'not exist: "%s"'),
1401                             $value]);
1402                 }
1403         } else {
1404                 my $rctlmax;
1405                 my $rctlflags;
1406                 my $rules;
1407
1408                 #
1409                 # See if rctl rules exist for this attribute.  If so, it
1410                 # is an rctl and is checked for valid values.
1411                 #
1412
1413                 # check hashed cache of rctl rules.
1414                 $rules = $RctlRules{$name};
1415                 if (!defined($rules)) {
1416
1417                         #
1418                         # See if this is an resource control name, if so
1419                         # cache rules.
1420                         #
1421                         ($rctlmax, $rctlflags) = rctl_get_info($name);
1422                         if (defined($rctlmax)) {
1423                                 $rules = proj_getrctlrules(
1424                                     $rctlmax, $rctlflags);
1425                                 if (defined($rules)) {
1426                                         $RctlRules{$name} = $rules;
1427                                 } else {
1428                                         $RctlRules{$name} = "NOT AN RCTL";
1429                                 }
1430                         }
1431                 }
1432
1433                 # If rules are defined, this is a resource control.
1434                 if (defined($rules) && ref($rules)) {
1435
1436                         ($result, $ref) =
1437                             projent_validate_rctl($attribute, $flags);
1438                         if ($result != 0) {
1439                                 $ret = 1;
1440                                 push(@errs, @$ref);
1441                         }
1442                 }
1443         }
1444         return ($ret, \@errs);
1445 }
1446
1447 #
1448 # projent_validate_attributes(ref to attribute list, flags)
1449 #
1450 # Validates all attributes in list of attribute references using
1451 # projent_validate_attribute.  flags is unused.
1452 # flags is unused.
1453 #
1454 sub projent_validate_attributes
1455 {
1456         my ($attributes, $flags) = @_;
1457         my @err;
1458         my $ret = 0;
1459         my $result = 0;
1460         my $ref;
1461         my $attribute;
1462
1463         foreach $attribute (@$attributes) {
1464
1465                 ($ret, $ref) = projent_validate_attribute($attribute, $flags);
1466                 if ($ret != 0) {
1467                         $result = $ret;
1468                         push(@err, @$ref);
1469                 }
1470         }
1471
1472         my %seen;
1473         my @dups = grep($seen{$_}++ == 1, map { $_->{'name'} } @$attributes);
1474         if (@dups) {
1475                 $result = 1;
1476                 push(@err, [3, gettext('Duplicate attributes "%s"'),
1477                     join(',', @dups)]);
1478         }
1479
1480         return ($result, \@err);
1481 }
1482
1483 #
1484 # projent_getrctlrules(max value, global flags)
1485 #
1486 # given an rctls max value and global flags, returns a ref to a hash
1487 # of rctl rules that is used by projent_validate_rctl to validate an
1488 # rctl's values.
1489 #
1490 sub proj_getrctlrules
1491 {
1492         my ($max, $flags) = @_;
1493         my $signals;
1494         my $rctl;
1495
1496         $rctl = {};
1497         $signals =
1498             [ qw(ABRT XRES HUP STOP TERM KILL),
1499               $SigNo{'ABRT'},
1500               $SigNo{'XRES'},
1501               $SigNo{'HUP'},
1502               $SigNo{'STOP'},
1503               $SigNo{'TERM'},
1504               $SigNo{'KILL'} ];
1505
1506         $rctl->{'max'} = $max;
1507
1508         if ($flags & &RCTL_GLOBAL_BYTES) {
1509                 $rctl->{'type'} = 'bytes';
1510         } elsif ($flags & &RCTL_GLOBAL_SECONDS) {
1511                 $rctl->{'type'} = 'seconds';
1512         } elsif ($flags & &RCTL_GLOBAL_COUNT)  {
1513                 $rctl->{'type'} = 'count';
1514         } else {
1515                 $rctl->{'type'} = 'unknown';
1516         }
1517         if ($flags & &RCTL_GLOBAL_NOBASIC) {
1518                 $rctl->{'privs'} = ['privileged', 'priv'];
1519         } else {
1520                 $rctl->{'privs'} = ['basic', 'privileged', 'priv'];
1521         }
1522
1523         if ($flags & &RCTL_GLOBAL_DENY_ALWAYS) {
1524                 $rctl->{'actions'} = ['deny'];
1525
1526         } elsif ($flags & &RCTL_GLOBAL_DENY_NEVER) {
1527                 $rctl->{'actions'} = ['none'];
1528         } else {
1529                 $rctl->{'actions'} = ['none', 'deny'];
1530         }
1531
1532         if ($flags & &RCTL_GLOBAL_SIGNAL_NEVER) {
1533                 $rctl->{'signals'} = [];
1534
1535         } else {
1536
1537                 push(@{$rctl->{'actions'}}, 'sig');
1538
1539                 if ($flags & &RCTL_GLOBAL_CPU_TIME) {
1540                         push(@$signals, 'XCPU', '30');
1541                 }
1542                 if ($flags & &RCTL_GLOBAL_FILE_SIZE) {
1543                         push(@$signals, 'XFSZ', '31');
1544                 }
1545                 $rctl->{'signals'} = $signals;
1546         }
1547         return ($rctl);
1548 }
1549
1550 #
1551 # projent_val2num(scaled value, "seconds" | "count" | "bytes")
1552 #
1553 # converts an integer or scaled value to an integer value.
1554 # returns (integer value, modifier character, unit character.
1555 #
1556 # On failure, integer value is undefined.  If the original
1557 # scaled value is a plain integer, modifier character and
1558 # unit character will be undefined.
1559 #
1560 sub projent_val2num
1561 {
1562         my ($val, $type) = @_;
1563         my %scaleM = ( k => 1000,
1564                        m => 1000000,
1565                        g => 1000000000,
1566                        t => 1000000000000,
1567                        p => 1000000000000000,
1568                        e => 1000000000000000000);
1569         my %scaleB = ( k => 1024,
1570                        m => 1048576,
1571                        g => 1073741824,
1572                        t => 1099511627776,
1573                        p => 1125899906842624,
1574                        e => 1152921504606846976);
1575
1576         my $scale;
1577         my $base;
1578         my ($num, $modifier, $unit);
1579         my $mul;
1580         my $string;
1581         my $i;
1582         my $undefined;
1583         my $exp_unit;
1584
1585         ($num, $modifier, $unit) = $val =~
1586             /^(\d+(?:\.\d+)?)(?i:([kmgtpe])?([bs])?)$/;
1587
1588         # No numeric match.
1589         if (!defined($num)) {
1590                 return ($undefined, $undefined, $undefined);
1591         }
1592
1593         # Decimal number with no scaling modifier.
1594         if (!defined($modifier) && $num =~ /^\d+\.\d+/) {
1595                 return ($undefined, $undefined, $undefined);
1596         }
1597
1598         if ($type eq 'bytes') {
1599                 $exp_unit = 'b';
1600                 $scale = \%scaleB;
1601         } elsif ($type eq 'seconds') {
1602                 $exp_unit = 's';
1603                 $scale = \%scaleM;
1604         } else {
1605                 $scale = \%scaleM;
1606         }
1607
1608         if (defined($unit)) {
1609                 $unit = lc($unit);
1610         }
1611
1612         # So not succeed if unit is incorrect.
1613         if (!defined($exp_unit) && defined($unit)) {
1614                 return ($undefined, $modifier, $unit);
1615         }
1616         if (defined($unit) && $unit ne $exp_unit) {
1617                 return ($undefined, $modifier, $unit);
1618         }
1619
1620         if (defined($modifier)) {
1621
1622                 $modifier = lc($modifier);
1623                 $mul = $scale->{$modifier};
1624                 $num = $num * $mul;
1625         }
1626
1627         # check for integer overflow.
1628         if ($num > $MaxNum) {
1629                 return ("OVERFLOW", $modifier, $unit);
1630         }
1631         #
1632         # Trim numbers that are decimal equivalent to the maximum value
1633         # to the maximum integer value.
1634         #
1635         if ($num == $MaxNum) {
1636                 $num = $MaxNum;;
1637
1638         } elsif ($num < $MaxNum) {
1639                 # convert any decimal numbers to an integer
1640                 $num = int($num);
1641         }
1642
1643         return ($num, $modifier, $unit);
1644 }
1645 #
1646 # projent_validate_rctl(ref to rctl attribute hash, flags)
1647 #
1648 # verifies that the given rctl hash with keys "name" and
1649 # "values" contains valid values for the given name.
1650 # flags is unused.
1651 #
1652 sub projent_validate_rctl
1653 {
1654         my ($rctl, $flags) = @_;
1655         my $allrules;
1656         my $rules;
1657         my $name;
1658         my $values;
1659         my $value;
1660         my $valuestring;
1661         my $ret = 0;
1662         my @err;
1663         my $priv;
1664         my $val;
1665         my @actions;
1666         my $action;
1667         my $signal;
1668         my $sigstring;  # Full signal string on right hand of signal=SIGXXX.
1669         my $signame;    # Signal number or XXX part of SIGXXX.
1670         my $siglist;
1671         my $nonecount;
1672         my $denycount;
1673         my $sigcount;
1674
1675         $name = $rctl->{'name'};
1676         $values = $rctl->{'values'};
1677
1678         #
1679         # Get the default rules for all rctls, and the specific rules for
1680         # this rctl.
1681         #
1682         $allrules = $RctlRules{'__DEFAULT__'};
1683         $rules = $RctlRules{$name};
1684
1685         if (!defined($rules) || !ref($rules)) {
1686                 $rules = $allrules;
1687         }
1688
1689         # Allow for no rctl values on rctl.
1690         if (!defined($values)) {
1691                 return (0, \@err);
1692         }
1693
1694         # If values exist, make sure it is a list.
1695         if (!ref($values)) {
1696
1697                 push(@err, [3, gettext(
1698                     'rctl "%s" missing value'), $name]);
1699                 return (1, \@err);
1700         }
1701
1702         foreach $value (@$values) {
1703
1704                 # Each value should be a list.
1705
1706                 if (!ref($value)) {
1707                         $ret = 1;
1708                         push(@err, [3, gettext(
1709                             'rctl "%s" value "%s" should be in ()\'s'),
1710                                      $name, $value]);
1711
1712                         next;
1713                 }
1714
1715                 ($priv, $val, @actions) = @$value;
1716                 if (!@actions) {
1717                         $ret = 1;
1718                         $valuestring = projent_values2string([$value]);
1719                         push(@err, [3, gettext(
1720                             'rctl "%s" value missing action "%s"'),
1721                             $name, $valuestring]);
1722                 }
1723
1724                 if (!defined($priv)) {
1725                         $ret = 1;
1726                         push(@err, [3, gettext(
1727                             'rctl "%s" value missing privilege "%s"'),
1728                             $name, $valuestring]);
1729
1730                 } elsif (ref($priv)) {
1731                         $ret = 1;
1732                         $valuestring = projent_values2string([$priv]);
1733                         push(@err, [3, gettext(
1734                             'rctl "%s" invalid privilege "%s"'),
1735                                      $name, $valuestring]);
1736
1737                 } else {
1738                         if (!(grep /^$priv$/, @{$allrules->{'privs'}})) {
1739
1740                                 $ret = 1;
1741                                 push(@err, [3, gettext(
1742                                     'rctl "%s" unknown privilege "%s"'),
1743                                     $name, $priv]);
1744
1745                         } elsif (!(grep /^$priv$/, @{$rules->{'privs'}})) {
1746
1747                                 $ret = 1;
1748                                 push(@err, [3, gettext(
1749                                     'rctl "%s" privilege not allowed '.
1750                                     '"%s"'), $name, $priv]);
1751                         }
1752                 }
1753                 if (!defined($val)) {
1754                         $ret = 1;
1755                         push(@err, [3, gettext(
1756                             'rctl "%s" missing value'), $name]);
1757
1758                 } elsif (ref($val)) {
1759                         $ret = 1;
1760                         $valuestring = projent_values2string([$val]);
1761                         push(@err, [3, gettext(
1762                             'rctl "%s" invalid value "%s"'),
1763                                      $name, $valuestring]);
1764
1765                 } else {
1766                         if ($val !~ /^\d+$/) {
1767                                 $ret = 1;
1768                                 push(@err, [3, gettext(
1769                                     'rctl "%s" value "%s" is not '.
1770                                     'an integer'), $name, $val]);
1771
1772                         } elsif ($val > $rules->{'max'}) {
1773                                 $ret = 1;
1774                                 push(@err, [3, gettext(
1775                                     'rctl "%s" value "%s" exceeds '.
1776                                     'system limit'), $name, $val]);
1777                         }
1778                 }
1779                 $nonecount = 0;
1780                 $denycount = 0;
1781                 $sigcount = 0;
1782
1783                 foreach $action (@actions) {
1784
1785                         if (ref($action)) {
1786                                 $ret = 1;
1787                                 $valuestring =
1788                                     projent_values2string([$action]);
1789                                 push(@err, [3, gettext(
1790                                     'rctl "%s" invalid action "%s"'),
1791                                      $name, $valuestring]);
1792
1793                                 next;
1794                         }
1795
1796                         if ($action =~ /^sig(nal)?(=.*)?$/) {
1797                                 $signal = $action;
1798                                 $action = 'sig';
1799                         }
1800                         if (!(grep /^$action$/, @{$allrules->{'actions'}})) {
1801
1802                                 $ret = 1;
1803                                 push(@err, [3, gettext(
1804                                     'rctl "%s" unknown action "%s"'),
1805                                     $name, $action]);
1806                                 next;
1807
1808                         } elsif (!(grep /^$action$/, @{$rules->{'actions'}})) {
1809
1810                                 $ret = 1;
1811                                 push(@err, [3, gettext(
1812                                     'rctl "%s" action not allowed "%s"'),
1813                                     $name, $action]);
1814                                 next;
1815                         }
1816
1817                         if ($action eq 'none') {
1818                                 if ($nonecount >= 1) {
1819
1820                                         $ret = 1;
1821                                         push(@err, [3, gettext(
1822                                             'rctl "%s" duplicate action '.
1823                                             'none'), $name]);
1824                                 }
1825                                 $nonecount++;
1826                                 next;
1827                         }
1828                         if ($action eq 'deny') {
1829                                 if ($denycount >= 1) {
1830
1831                                         $ret = 1;
1832                                         push(@err, [3, gettext(
1833                                             'rctl "%s" duplicate action '.
1834                                             'deny'), $name]);
1835                                 }
1836                                 $denycount++;
1837                                 next;
1838                         }
1839
1840                         # action must be signal
1841                         if ($sigcount >= 1) {
1842
1843                                 $ret = 1;
1844                                 push(@err, [3, gettext(
1845                                     'rctl "%s" duplicate action sig'),
1846                                     $name]);
1847                         }
1848                         $sigcount++;
1849
1850                         #
1851                         # Make sure signal is correct format, one of:
1852                         # sig=##
1853                         # signal=##
1854                         # sig=SIGXXX
1855                         # signal=SIGXXX
1856                         # sig=XXX
1857                         # signal=SIGXXX
1858                         #
1859                         ($sigstring) = $signal =~
1860                             /^
1861                                  (?:signal|sig)=
1862                                      (\d+|
1863                                      (?:SIG)?[[:upper:]]+(?:[+-][123])?
1864                                  )
1865                              $/x;
1866
1867                         if (!defined($sigstring)) {
1868                                 $ret = 1;
1869                                 push(@err, [3, gettext(
1870                                     'rctl "%s" invalid signal "%s"'),
1871                                     $name, $signal]);
1872                                 next;
1873                         }
1874
1875                         $signame = $sigstring;
1876                         $signame =~ s/SIG//;
1877
1878                         # Make sure specific signal is allowed.
1879                         $siglist = $allrules->{'signals'};
1880                         if (!(grep /^$signame$/, @$siglist)) {
1881                                 $ret = 1;
1882                                 push(@err, [3, gettext(
1883                                     'rctl "%s" invalid signal "%s"'),
1884                                     $name, $signal]);
1885                                 next;
1886                         }
1887                         $siglist = $rules->{'signals'};
1888
1889                         if (!(grep /^$signame$/, @$siglist)) {
1890                                 $ret = 1;
1891                                 push(@err, [3, gettext(
1892                                     'rctl "%s" signal not allowed "%s"'),
1893                                     $name, $signal]);
1894                                 next;
1895                         }
1896                 }
1897
1898                 if ($nonecount && ($denycount || $sigcount)) {
1899                         $ret = 1;
1900                         push(@err, [3, gettext(
1901                             'rctl "%s" action "none" specified with '.
1902                             'other actions'), $name]);
1903                 }
1904         }
1905
1906         if (@err) {
1907                 return ($ret, \@err);
1908         } else {
1909             return ($ret, \@err);
1910         }
1911 }
1912
1913 1;