This file is indexed.

/usr/share/perl5/Paranoid/Args.pm is in libparanoid-perl 2.05-2.

This file is owned by root:root, with mode 0o644.

The actual contents of the file can be viewed below.

   1
   2
   3
   4
   5
   6
   7
   8
   9
  10
  11
  12
  13
  14
  15
  16
  17
  18
  19
  20
  21
  22
  23
  24
  25
  26
  27
  28
  29
  30
  31
  32
  33
  34
  35
  36
  37
  38
  39
  40
  41
  42
  43
  44
  45
  46
  47
  48
  49
  50
  51
  52
  53
  54
  55
  56
  57
  58
  59
  60
  61
  62
  63
  64
  65
  66
  67
  68
  69
  70
  71
  72
  73
  74
  75
  76
  77
  78
  79
  80
  81
  82
  83
  84
  85
  86
  87
  88
  89
  90
  91
  92
  93
  94
  95
  96
  97
  98
  99
 100
 101
 102
 103
 104
 105
 106
 107
 108
 109
 110
 111
 112
 113
 114
 115
 116
 117
 118
 119
 120
 121
 122
 123
 124
 125
 126
 127
 128
 129
 130
 131
 132
 133
 134
 135
 136
 137
 138
 139
 140
 141
 142
 143
 144
 145
 146
 147
 148
 149
 150
 151
 152
 153
 154
 155
 156
 157
 158
 159
 160
 161
 162
 163
 164
 165
 166
 167
 168
 169
 170
 171
 172
 173
 174
 175
 176
 177
 178
 179
 180
 181
 182
 183
 184
 185
 186
 187
 188
 189
 190
 191
 192
 193
 194
 195
 196
 197
 198
 199
 200
 201
 202
 203
 204
 205
 206
 207
 208
 209
 210
 211
 212
 213
 214
 215
 216
 217
 218
 219
 220
 221
 222
 223
 224
 225
 226
 227
 228
 229
 230
 231
 232
 233
 234
 235
 236
 237
 238
 239
 240
 241
 242
 243
 244
 245
 246
 247
 248
 249
 250
 251
 252
 253
 254
 255
 256
 257
 258
 259
 260
 261
 262
 263
 264
 265
 266
 267
 268
 269
 270
 271
 272
 273
 274
 275
 276
 277
 278
 279
 280
 281
 282
 283
 284
 285
 286
 287
 288
 289
 290
 291
 292
 293
 294
 295
 296
 297
 298
 299
 300
 301
 302
 303
 304
 305
 306
 307
 308
 309
 310
 311
 312
 313
 314
 315
 316
 317
 318
 319
 320
 321
 322
 323
 324
 325
 326
 327
 328
 329
 330
 331
 332
 333
 334
 335
 336
 337
 338
 339
 340
 341
 342
 343
 344
 345
 346
 347
 348
 349
 350
 351
 352
 353
 354
 355
 356
 357
 358
 359
 360
 361
 362
 363
 364
 365
 366
 367
 368
 369
 370
 371
 372
 373
 374
 375
 376
 377
 378
 379
 380
 381
 382
 383
 384
 385
 386
 387
 388
 389
 390
 391
 392
 393
 394
 395
 396
 397
 398
 399
 400
 401
 402
 403
 404
 405
 406
 407
 408
 409
 410
 411
 412
 413
 414
 415
 416
 417
 418
 419
 420
 421
 422
 423
 424
 425
 426
 427
 428
 429
 430
 431
 432
 433
 434
 435
 436
 437
 438
 439
 440
 441
 442
 443
 444
 445
 446
 447
 448
 449
 450
 451
 452
 453
 454
 455
 456
 457
 458
 459
 460
 461
 462
 463
 464
 465
 466
 467
 468
 469
 470
 471
 472
 473
 474
 475
 476
 477
 478
 479
 480
 481
 482
 483
 484
 485
 486
 487
 488
 489
 490
 491
 492
 493
 494
 495
 496
 497
 498
 499
 500
 501
 502
 503
 504
 505
 506
 507
 508
 509
 510
 511
 512
 513
 514
 515
 516
 517
 518
 519
 520
 521
 522
 523
 524
 525
 526
 527
 528
 529
 530
 531
 532
 533
 534
 535
 536
 537
 538
 539
 540
 541
 542
 543
 544
 545
 546
 547
 548
 549
 550
 551
 552
 553
 554
 555
 556
 557
 558
 559
 560
 561
 562
 563
 564
 565
 566
 567
 568
 569
 570
 571
 572
 573
 574
 575
 576
 577
 578
 579
 580
 581
 582
 583
 584
 585
 586
 587
 588
 589
 590
 591
 592
 593
 594
 595
 596
 597
 598
 599
 600
 601
 602
 603
 604
 605
 606
 607
 608
 609
 610
 611
 612
 613
 614
 615
 616
 617
 618
 619
 620
 621
 622
 623
 624
 625
 626
 627
 628
 629
 630
 631
 632
 633
 634
 635
 636
 637
 638
 639
 640
 641
 642
 643
 644
 645
 646
 647
 648
 649
 650
 651
 652
 653
 654
 655
 656
 657
 658
 659
 660
 661
 662
 663
 664
 665
 666
 667
 668
 669
 670
 671
 672
 673
 674
 675
 676
 677
 678
 679
 680
 681
 682
 683
 684
 685
 686
 687
 688
 689
 690
 691
 692
 693
 694
 695
 696
 697
 698
 699
 700
 701
 702
 703
 704
 705
 706
 707
 708
 709
 710
 711
 712
 713
 714
 715
 716
 717
 718
 719
 720
 721
 722
 723
 724
 725
 726
 727
 728
 729
 730
 731
 732
 733
 734
 735
 736
 737
 738
 739
 740
 741
 742
 743
 744
 745
 746
 747
 748
 749
 750
 751
 752
 753
 754
 755
 756
 757
 758
 759
 760
 761
 762
 763
 764
 765
 766
 767
 768
 769
 770
 771
 772
 773
 774
 775
 776
 777
 778
 779
 780
 781
 782
 783
 784
 785
 786
 787
 788
 789
 790
 791
 792
 793
 794
 795
 796
 797
 798
 799
 800
 801
 802
 803
 804
 805
 806
 807
 808
 809
 810
 811
 812
 813
 814
 815
 816
 817
 818
 819
 820
 821
 822
 823
 824
 825
 826
 827
 828
 829
 830
 831
 832
 833
 834
 835
 836
 837
 838
 839
 840
 841
 842
 843
 844
 845
 846
 847
 848
 849
 850
 851
 852
 853
 854
 855
 856
 857
 858
 859
 860
 861
 862
 863
 864
 865
 866
 867
 868
 869
 870
 871
 872
 873
 874
 875
 876
 877
 878
 879
 880
 881
 882
 883
 884
 885
 886
 887
 888
 889
 890
 891
 892
 893
 894
 895
 896
 897
 898
 899
 900
 901
 902
 903
 904
 905
 906
 907
 908
 909
 910
 911
 912
 913
 914
 915
 916
 917
 918
 919
 920
 921
 922
 923
 924
 925
 926
 927
 928
 929
 930
 931
 932
 933
 934
 935
 936
 937
 938
 939
 940
 941
 942
 943
 944
 945
 946
 947
 948
 949
 950
 951
 952
 953
 954
 955
 956
 957
 958
 959
 960
 961
 962
 963
 964
 965
 966
 967
 968
 969
 970
 971
 972
 973
 974
 975
 976
 977
 978
 979
 980
 981
 982
 983
 984
 985
 986
 987
 988
 989
 990
 991
 992
 993
 994
 995
 996
 997
 998
 999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
# Paranoid::Args -- Command-line argument parsing functions
#
# (c) 2005 - 2017, Arthur Corliss <corliss@digitalmages.com>
#
# $Id: lib/Paranoid/Args.pm, 2.05 2017/02/06 01:48:57 acorliss Exp $
#
#    This software is licensed under the same terms as Perl, itself.
#    Please see http://dev.perl.org/licenses/ for more information.
#
#####################################################################

#####################################################################
#
# Environment definitions
#
#####################################################################

package Paranoid::Args;

use 5.008;

use strict;
use warnings;
use vars qw($VERSION @EXPORT @EXPORT_OK %EXPORT_TAGS);
use base qw(Exporter);
use Paranoid;
use Paranoid::Debug qw(:all);

($VERSION) = ( q$Revision: 2.05 $ =~ /(\d+(?:\.\d+)+)/sm );

@EXPORT      = qw(parseArgs);
@EXPORT_OK   = @EXPORT;
%EXPORT_TAGS = ( all => [@EXPORT_OK], );

#####################################################################
#
# Module code follows
#
#####################################################################

{

    # Internal boolean flag for noOptions
    my $noOptions = 0;

    sub _NOOPTIONS : lvalue {

        # Purpose:  Gets/sets value of boolean flag $noOptions
        # Returns:  Value of $noOptions
        # Usage:    $flag = _NOOPTIONS;
        # Usage:    _NOOPTIONS = 1;

        $noOptions;
    }

    # Internal errors array
    my @errors;

    sub _resetErrors {

        # Purpose:  Empties @errors
        # Returns:  True (1)
        # Usage:    resetErrors();

        @errors = ();
        return 1;
    }

    sub _pushErrors {

        # Purpose:  Pushes a new string onto the @errors array
        # Returns:  Same argument as called with
        # Usage:    _pushErrors($message);

        my $message = shift;
        push @errors, $message;
        return $message;
    }

    sub listErrors {

        # Purpose:  Gets the contents of @errors
        # Returns:  Contents of @errors
        # Usage:    @errors = listErrors();

        return @errors;
    }

    # Internal options hash
    my %options;

    sub _getOption {

        # Purpose:  Gets the template associated with passed option
        # Returns:  Reference to template hash or undef should the
        #           requested option not be defined
        # Usage:    $tref = _getOption($option);

        my $option = shift;

        return exists $options{$option} ? $options{$option} : undef;
    }

    sub _setOption {

        # Purpose:  Associates the passed option to the passed template in
        #           %options
        # Returns:  True (1)
        # Usage:    _setOption($option, $tref);

        my $option = shift;
        my $tref   = shift;

        $options{$option} = $tref;

        return 1;
    }

    sub _optionsKeys {

        # Purpose:  Returns a list of keys from %options
        # Returns:  keys %options
        # Usage:    @keys = _optionsKeys();

        return keys %options;
    }

    sub _resetOptions {

        # Purpose:  Empties the %options
        # Returns:  True (1)
        # Usage:    _resetOptions();

        %options = ();

        return 1;
    }

    # Internal arguments list
    my @arguments;

    sub _getArgRef {

        # Purpose:  Gets a reference the argument array
        # Returns:  Array reference
        # Usage:    $argRef = _getArgRef();

        return \@arguments;
    }

    sub clearMemory {

        # Purpose:  Empties all internal data structures
        # Returns:  True (1)
        # Usage:    clearMemory();

        _NOOPTIONS = 0;
        _resetErrors();
        _resetOptions();
        @{ _getArgRef() } = ();

        return 1;
    }
}

sub _tLint {

    # Purpose:  Performs basic checks on a given option template for
    #           correctness
    # Returns:  True (1) if all checks pass, False (0) otherwise
    # Usage:    $rv = _tLint($templateRef);

    my $tref = shift;    # Reference to option template hash
    my $rv   = 1;
    my ( $oname, @at );

    pdebug( 'entering w/(%s)', PDLEVEL2, $tref );
    pIn();

    # Get the option name for reporting purposes (should have been populated
    # within parseArgs below)
    $oname = $$tref{Name};

    # Make sure a short or long option is declared
    if ( $oname eq 'undef/undef' ) {
        _pushErrors('No short or long option name declared');
        $rv = 0;
    }

    # Make sure the argument template is defined
    if ($rv) {
        unless ( defined $$tref{Template} ) {
            _pushErrors("$oname option declared without a template");
            $rv = 0;
        }
    }

    # Make sure the template contains only supported characters
    if ($rv) {
        unless ( defined $$tref{Template}
            && $$tref{Template} =~ /^[\$\@]*$/s ) {
            _pushErrors( "$oname option declared with an invalid template"
                    . "($$tref{Template})" );
            $rv = 0;
        }
    }

    # Make sure option names are sane
    if ($rv) {
        if ( defined $$tref{Short} ) {
            unless ( $$tref{Short} =~ /^[a-zA-Z0-9]$/s ) {
                _pushErrors(
                    "Invalid name for the short option ($$tref{Short})");
                $rv = 0;
            }
        }
        if ( defined $$tref{Long} ) {
            unless ( $$tref{Long} =~ /^[a-zA-Z0-9-]{2,}$/s ) {
                _pushErrors(
                    "Invalid name for the long option ($$tref{Long})");
                $rv = 0;
            }
        }
    }

    # Make sure '@' is only used once, if at all, and the option isn't
    # set to allow bundling
    if ($rv) {
        if ( $$tref{Template} =~ /\@/sm ) {
            @at = ( $$tref{Template} =~ m#(\@)#sg );
            if ( @at > 1 ) {
                _pushErrors( 'The \'@\' symbol can only be used once in the '
                        . "template for $oname: $_" );
                $rv = 0;
            }
            if ( $$tref{CanBundle} and defined $$tref{Short} ) {
                _pushErrors(
                    "Option $$tref{Short} must have CanBundle set to false "
                        . 'if the template contains \'@\'' );
                $rv = 0;
            }
        }
    }

    # Make sure all values in our lists are defined
    if ($rv) {
        unless ( ref( $$tref{ExclusiveOf} ) eq 'ARRAY' ) {
            _pushErrors( "Option ${oname}'s parameter ExclusiveOf must be an "
                    . 'array reference' );
            $rv = 0;
        }
        unless ( ref( $$tref{AccompaniedBy} ) eq 'ARRAY' ) {
            _pushErrors(
                      "Option ${oname}'s parameter AccompaniedBy must be an "
                    . 'array reference' );
            $rv = 0;
        }
        if ($rv) {
            if ( grep { !defined } @{ $$tref{ExclusiveOf} } ) {
                _pushErrors(
                    "Option $oname has undefined values in ExclusiveOf");
                $rv = 0;
            }
            if ( grep { !defined } @{ $$tref{AccompaniedBy} } ) {
                _pushErrors(
                    "Option $oname has undefined values in ExclusiveOf");
                $rv = 0;
            }
        }
    }

    # Make sure CountShort is enabled only for those with a template of ''
    # or '$'
    if ($rv) {
        if ( $$tref{CountShort} ) {
            unless ( $$tref{Template} =~ /^\$?$/sm ) {
                _pushErrors( "Option $oname has CountShort set but with an "
                        . 'incompatible template' );
                $rv = 0;
            }
        }
    }

    pOut();
    pdebug( 'leaving w/rv: %s', PDLEVEL2, $rv );

    return $rv;
}

sub _getArgs ($$\@) {

    # Purpose:  Takes passed argument template and extracts the requisite
    #           arguments to satisfy it from the argument list.  The
    #           results are stored in the passed option list.
    # Results:  True (1) if successful, False (0) if not
    # Usage:    $rv = _getArgs($option, $argTemplate, @optionArgs);

    my $option      = shift;         # Option name
    my $argTemplate = shift;         # Option argument template
    my $lref        = shift;         # Array reference for retrieved arguments
    my $rv          = 1;
    my $argRef      = _getArgRef();
    my @tmp;

    pdebug( 'entering w/(%s)(%s)(%s)',
        PDLEVEL2, $option, $argTemplate, $lref );
    pIn();

    # Empty the array
    @$lref = ();

    pdebug( 'contents of args: %s', PDLEVEL4, @$argRef );

    # Start checking the contents of $argTemplate
    if ( $argTemplate eq '' ) {

        # Template is '' (boolean option)
        @$lref = (1);

    } elsif ( $argTemplate =~ /\@/s ) {

        # Template has a '@' in it -- we'll need to
        # grab as many of the next arguments as possible.

        # Check the noOptions flags
        if (_NOOPTIONS) {

            # True: gobble up everything left
            push @$lref, @$argRef;
            @$argRef = ();

        } else {

            # False: gobble up to the next option-looking thing
            while ( @$argRef and $$argRef[0] !~ /^--?(?:\w+.*)?$/s ) {
                push @$lref, shift @$argRef;
            }

            # Now, we check to see if the first remaining argument is '--'.
            # If it is then we must set noOptions to true and gobble the
            # rest.
            if ( @$argRef and $$argRef[0] eq '--' ) {
                _NOOPTIONS = 1;
                shift @$argRef;
                push @$lref, @$argRef;
                @$argRef = ();
            }
        }

    } else {

       # The template is not empty and has no '@', so we'll just grab the next
       # n arguments, n being the length of the template

        # Check the noOptions flag
        if (_NOOPTIONS) {

            # True:  grab everything we need
            while ( @$argRef and @$lref < length $argTemplate ) {
                push @$lref, shift @$argRef;
            }

        } else {

            # False:  grab as many non-option-looking things as we can
            while ( @$argRef
                and $$argRef[0] !~ /^--?(?:\w+.*)$/s
                and @$lref < length $argTemplate ) {
                push @$lref, shift @$argRef;
            }

            # Now, we check to see if we still need more arguments and if
            # the first remaining argument is '--'.  If it is then we must
            # set noOptions to true and gobble what we need.
            if (    @$lref < length $argTemplate
                and @$argRef
                and $$argRef[0] eq '--' ) {
                _NOOPTIONS = 1;
                shift @$argRef;
                while ( @$argRef and @$lref < length $argTemplate ) {
                    push @$lref, shift @$argRef;
                }
            }
        }
    }

    # Final check:  did we get minimum requisite number of arguments?
    if ( @$lref < length $argTemplate ) {
        _pushErrors(
            pdebug(
                'Missing the minimum number of arguments for %s', PDLEVEL1,
                $option
                ) );
        $rv = 0;
    } else {
        pdebug( 'extracted the following arguments: %s', PDLEVEL3, @$lref );
    }

    # sublist '@' portions of multicharacter templates
    if ( $rv and $argTemplate =~ /\@/sm and length $argTemplate > 1 ) {
        @tmp = ( [], [], [] );

        # First, shift off all preceding '$'s
        if ( $argTemplate =~ /^(\$+)/s ) {
            @{ $tmp[0] } = splice @$lref, 0, length $1;
        }

        # Next, pop off all trailing '$'
        if ( $argTemplate =~ /(\$+)\$/s ) {
            @{ $tmp[2] } = splice @$lref, -1 * length $1;
        }

        # Everything left belongs to the '@'
        @{ $tmp[1] } = @$lref;

        # Let's put it all together...
        @$lref = ();
        push @$lref, @{ $tmp[0] } if @{ $tmp[0] };
        push @$lref, $tmp[1];
        push @$lref, @{ $tmp[2] } if @{ $tmp[2] };

        pdebug( 'sublisted arguments into: %s', PDLEVEL3, @$lref );
    }

    pOut();
    pdebug( 'leaving w/rv: %s', PDLEVEL2, $rv );

    return $rv;
}

sub _storeArgs ($$\@) {

    # Purpose:  Stores the passed option arguments in the passed option
    #           template's Value, but in accordance with parameters in the
    #           template
    # Returns:  True (1)
    # Usage:    _storeArgs($optionTemplate, $argTemplate, @optionArgs);

    my $tref        = shift;
    my $argTemplate = shift;
    my $lref        = shift;

    pdebug( 'entering w/(%s)(%s)(%s)', PDLEVEL2, $tref, $argTemplate, $lref );
    pIn();

    pdebug( 'adding values to %s', PDLEVEL3, $$tref{Name} );

    # Increment our usage counter
    $$tref{Count}++;

    # Store arguments according to the template
    if ( $argTemplate eq '' ) {

        # Template is ''
        $$tref{Value} = 0 unless defined $$tref{Value};
        $$tref{Value}++;
        pdebug( 'Value is now %s', PDLEVEL3, $$tref{Value} );

    } elsif ( $argTemplate eq '$' ) {

        # Template is '$'
        if ( not $$tref{Multiple} or $$tref{CountShort} ) {

            # Store the value directly since we
            # can only be used once
            $$tref{Value} = $$lref[0];
            pdebug( 'Value is now %s', PDLEVEL3, $$tref{Value} );

        } else {

            # Store the value as part of a list since
            # we can be used multiple times
            $$tref{Value} = []
                unless defined $$tref{Value}
                    and ref $$tref{Value} eq 'ARRAY';
            push @{ $$tref{Value} }, $$lref[0];
            pdebug( 'Value is now %s', PDLEVEL3, @{ $$tref{Value} } );
        }

    } else {

        # Template is anything else
        if ( not $$tref{Multiple} ) {

            # Store the values directly in a an array
            # since we can only be used once
            $$tref{Value} = [@$lref];
            pdebug( 'Value is now %s', PDLEVEL3, @{ $$tref{Value} } );

        } else {

            # Store the values as an element of an
            # array since we can be used multiple times
            $$tref{Value} = []
                unless defined $$tref{Value}
                    and ref $$tref{Value} eq 'ARRAY';
            push @{ $$tref{Value} }, [@$lref];
            pdebug( 'Value now has %d sets',
                PDLEVEL3, scalar @{ $$tref{Value} } );
        }
    }

    pOut();
    pdebug( 'leaving w/rv: 1', PDLEVEL2 );

    return 1;
}

sub parseArgs (\@\%;\@) {

    # Purpose:  Extracts and validates all command-line arguments and options,
    #           storing them in an organized hash for easy retrieval
    # Returns:  True (1) if successful, False (0) if not
    # Usage:    $rv = parseArgs(@templates, %options);
    # Usage:    $rv = parseArgs(@templates, %options, @args);

    my $tlref = shift;    # Templates list ref
    my $oref  = shift;    # Options hash ref
    my $paref = shift;    # Program argument list ref
    my $rv    = 1;
    my ( $tref, $oname, $argRef, $arg, $argTemplate );
    my ( @tmp, @oargs, $regex );

    # Validate arguments
    $paref = \@ARGV unless defined $paref;

    pdebug( 'entering w/(%s)(%s)(%s)', PDLEVEL1, $tlref, $oref, $paref );
    pIn();

    # Clear all internal data structures and reset flag
    clearMemory();

    # Empty the passed options hash
    %$oref = ();

    # Make a copy of the argument list
    $argRef  = _getArgRef();
    @$argRef = (@$paref);

    # Assemble %options and lint-check the templates
    foreach (@$tlref) {

        # Make sure the element is a hash reference
        unless ( ref $_ eq 'HASH' ) {
            _pushErrors('Illegal non-hash reference in templates array');
            $rv = 0;
            next;
        }

        # Establish a base template and copy the contents of the passed hash
        $tref = {
            Short         => undef,
            Long          => undef,
            Template      => '',
            Multiple      => 0,
            ExclusiveOf   => [],
            AccompaniedBy => [],
            CanBundle     => 0,
            CountShort    => 0,
            Value         => undef,
            %$_,
            };

        # Create the short/long option for error-reporting purposes
        $oname =
              ( defined $$tref{Short} ? $$tref{Short} : 'undef' ) . '/'
            . ( defined $$tref{Long}  ? $$tref{Long}  : 'undef' );
        $$tref{Name} = $oname;

        # Initialize our usage counter
        $$tref{Count} = 0;

        # We'll associate both the long and short options to the same hash
        # to make sure that we count/collect everything appropriately.
        #
        # Store the short option
        if ( defined $$tref{Short} and length $$tref{Short} ) {

            # See if a template is already defined
            if ( defined _getOption( $$tref{Short} ) ) {

                # It is -- report the error
                Paranoid::ERROR = _pushErrors(
                    pdebug(
                        'the %s option has more than one template',
                        PDLEVEL1, $$tref{Short} ) );
                $rv = 0;

            } else {

                # It's not -- go ahead and store it
                _setOption( $$tref{Short}, $tref );
            }
        }

        # Store the long option
        if ( defined $$tref{Long} and length $$tref{Long} ) {

            # See if a template is already defined
            if ( defined _getOption( $$tref{Long} ) ) {

                # It is -- report the error
                Paranoid::ERROR = _pushErrors(
                    pdebug(
                        'the %s option has more than one template',
                        PDLEVEL1, $$tref{Long} ) );
                $rv = 0;

            } else {

                # It's not -- go ahead and store it
                _setOption( $$tref{Long}, $tref );
            }
        }

        # Do a basic lint-check on the template
        $rv = 0 unless _tLint($tref);
    }

    if ($rv) {

        while (@$argRef) {
            $arg = shift @$argRef;
            next unless defined $arg;

            # Start testing $arg
            if ( $arg eq '--' and not _NOOPTIONS ) {

                # $arg is '--', so set the no options flag
                _NOOPTIONS = 1;

            } elsif ( not _NOOPTIONS and $arg =~ /^--?/s ) {

                # '--' hasn't been passed yet and this looks
                # like an option...

                # Test types of options
                if ( $arg =~ /^-(\w.*)$/s ) {

                    # With a single '-' it should be a short option.  However,
                    # we'll split the option portion, in case there's more
                    # than one character
                    @tmp = split //s, $1;

                    # If there's more than one character for the option name
                    # it must be either a bunch of bundled options or an
                    # option with a concatenated argument.  In case of the
                    # latter (assuming that CanBundle is set to false (a
                    # prerequisite of argument concatenation) and it has a
                    # template of '$' (another prerequisite)) we'll unshift
                    # the rest of the characters back onto the argument list.
                    #
                    # Oh, but first we'll need to get the applicable
                    # option template and then start testing...
                    $tref = _getOption( $tmp[0] );
                    if (    $#tmp
                        and defined $tref
                        and $$tref{Template} eq '$'
                        and not $$tref{CanBundle} ) {
                        unshift @$argRef, join '', @tmp[ 1 .. $#tmp ];
                        splice @tmp, 1;
                    }

                    # Start processing all remaining short options in @tmp
                    foreach (@tmp) {

                        # Get the template
                        $tref = _getOption($_);

                        # Make sure the option is supported
                        if ( defined $tref ) {

                            # Make sure option allows bundling if bundled
                            if ($#tmp) {
                                unless ( $$tref{CanBundle} ) {
                                    _pushErrors(
                                              "Option $_ used bundled with "
                                            . 'other options' );
                                    $rv = 0;
                                    next;
                                }
                            }

                            # Get the argument template
                            $argTemplate = $$tref{Template};

                            # Override the template if CountShort is true
                            $argTemplate = ''
                                if $argTemplate eq '$'
                                    and $$tref{CountShort};

                            # Get any accompanying arguments
                            unless ( _getArgs( "-$_", $argTemplate, @oargs ) )
                            {
                                $rv = 0;
                                next;
                            }

                            # Check if we've call this more than once
                            if ( not $$tref{Multiple}
                                and $$tref{Count} > 0 ) {
                                _pushErrors( "Option -$_ is only allowed "
                                        . 'to be used once' );
                                $rv = 0;
                                next;
                            }

                            # Store the values
                            _storeArgs( $tref, $argTemplate, @oargs );

                        } else {

                            # Warn that this is an unknown option
                            _pushErrors("Unknown short option used: $_");
                            $rv = 0;
                        }
                    }

                } elsif ( $arg =~ /^--([\w-]+)(?:=(.+))?$/sm ) {

                    # Starts with '--', so must be a long option

                    # Save the extracted option/argument portion
                    @tmp = ($1);
                    push @tmp, $2 if defined $2 and length $2;

                    # If this option had an argument portion we need to
                    # unshift it back onto the argument list *provided* it was
                    # a legal argument, i.e., this option had a template of
                    # '$'.
                    $tref = _getOption( $tmp[0] );
                    if ( $#tmp and defined $tref ) {

                        # Test for various templates
                        if ( $$tref{Template} eq '$' ) {

                            # Legal invocation  -- unshift away
                            unshift @$argRef, $tmp[1];

                        } elsif ( $$tref{Template} eq '' ) {

                            # Illegal, no arguments expected
                            _pushErrors( "--$tmp[0] does not require any "
                                    . 'arguments' );
                            $rv = 0;
                            next;

                        } else {

                            # Illegal, can't use concatenated arguments in
                            # more complex templates
                            _pushErrors( "--$tmp[0] cannot be called like "
                                    . 'this when multiple arguments are '
                                    . 'required.' );
                        }
                    }

                    # Handle known options
                    if ( defined $tref ) {

                        # Get the argument template
                        $argTemplate = $$tref{Template};

                        # Snarf extra arguments
                        unless (
                            _getArgs( "--$tmp[0]", $argTemplate, @oargs ) ) {
                            $rv = 0;
                            next;
                        }

                        # Check if we've call this more than once
                        if ( not $$tref{Multiple} and $$tref{Count} > 0 ) {
                            _pushErrors(
                                "Option --$_ is only allowed to be used once"
                                );
                            $rv = 0;
                            next;
                        }

                        # Store the values
                        _storeArgs( $tref, $argTemplate, @oargs );

                    } else {

                        # Unknown long option
                        _pushErrors("Unknown option: --$tmp[0]");
                        $rv = 0;
                    }

                } else {

                    # Unknown option-looking thingy
                    _pushErrors("Unknown option thingy: $arg");
                    $rv = 0;
                }

            } else {

                # Everything else is payload
                $$oref{PAYLOAD} = [] unless exists $$oref{PAYLOAD};
                push @{ $$oref{PAYLOAD} }, $arg;
            }
        }
    }

    # Make a list of all the arguments that was used
    @tmp = ();
    foreach ( _optionsKeys() ) {
        push @tmp, $_ if ${ _getOption($_) }{Count};
    }

    # Final sanity check
    foreach ( sort @tmp ) {
        $tref = _getOption($_);

        # Make sure nothing was called that is exclusive of
        # other called options
        if ( @{ $$tref{ExclusiveOf} } ) {
            $regex = '(?:' . join( '|', @{ $$tref{ExclusiveOf} } ) . ')';
            if ( grep /^$regex$/sm, @tmp ) {
                _pushErrors(
                    "$_ cannot be called with the following options: "
                        . join ', ',
                    @{ $$tref{ExclusiveOf} } );
                $rv = 0;
            }
        }

        # Make sure the option was called in conjunction with others
        foreach $regex ( @{ $$tref{AccompaniedBy} } ) {
            unless ( grep /^\Q$regex\E$/sm, @tmp ) {
                _pushErrors(
                    "$_ must be called with the following options: "
                        . join ', ',
                    @{ $$tref{AccompaniedBy} } );
                $rv = 0;
            }
        }

        # Copy the values into %$oref
        $$oref{$_} = $$tref{Value};
    }

    pOut();
    pdebug( 'leaving w/rv: %s', PDLEVEL1, $rv );

    return $rv;
}

1;

__END__

=head1 NAME

Paranoid::Args - Command-line argument parsing functions

=head1 VERSION

$Id: lib/Paranoid/Args.pm, 2.05 2017/02/06 01:48:57 acorliss Exp $

=head1 SYNOPSIS

  use Paranoid::Args;

  $rv = parseArgs(@templates, %opts);
  $rv = parseArgs(@templates, %opts, @args);

  @errors = Paranoid::Args::listErrors();
  Paranoid::Args::clearMemory();

=head1 DESCRIPTION

The purpose of this module is to provide simplified but validated parsing and
extraction of command-line arguments (otherwise known as the contents of
@ARGV).  It is meant to be used in lieu of modules like B<Getopt::Std> and
B<Getopt::Long>, but that does not mean that this module is functionally
equivalent -- it isn't.  There are things that those modules do that this
doesn't, but that's primarily by design.  My priorities are a bit different
when it comes to this particular task.

The primary focus of this module is validation, with the secondary focus being
preservation of context.

=head2 VALIDATION

When validating the use of options and arguments we concern ourselves
primarily the following things:

=over

=item 1)

Is the option accompanied by the requisite arguments?

=item 2)

Was the option called with the other requisite options?

=item 3)

Was the option called without options meant only for mutually exclusive 
use?

=item 4)

Were any unrecognized options used?

=back

This module also does basic sanity validation of all option templates to
ensure correct usage of this module.

=head2 PRESERVATION OF CONTEXT

Simply put, preservation of context means remembering the order and grouping
of associated arguments.  Take the hypothetical case of "tagging" files.  
The traditional approach is to define an option that takes a single string 
argument and apply them to the remaining contents of @ARGV:

  ./foo.pl -t "tag1" file1 file2

This module supports that model, with the option argument template being '$'
for that single string.  But what if you wanted to apply different tags to
different files with one command execution?

  ./foo.pl -t "tag1" file1 file2 -t "tag2" file3

In this case it is important to keep each group of payloads that you want to
operate on separate.  With this module you could instead use an argument
template of '$@', which would return each set independently:

  %opt = (
    't' => [
            [ "tag1", [ "file1", "file2" ] ],
            [ "tag2", [ "file3" ] ],
           ],
          );

Notice that we also preserve the context between the '$' and the '@' by
putting the '@' arguments in a sublist.  With this example that could possible
be considered pointless, but we also support templates like '$$@$' which makes
this very useful.  Now, instead of having to shift or pop off the
encapsulating arguments they now have one permanent ordinal index.  You also
can now just grab the array reference for the '@' portion and iterate over a
complete and separate list rather than having to take a splice of the complete
argument array.

It's probably just me, but I find that a little easier to track.

=head2 SUPPORTED COMMAND-LINE SYNTAX

The following list of syntactical options are supported:

=over

=item o

Short option bundling (i.e., "rm -rf")

=item o

Short option counting (i.e., "ssh -vvv")

=item o

Short option argument concatenation (i.e., "cut -d' '")

=item o

Long option "equals" argument concatenation (i.e., "./configure
--prefix=/usr")

=item o

The use of '--' to designate all following arguments are strictly that, even
if they look like options.

=back

This module don't support the hash key/value pairs (i.e., -s foo=one 
bar=two) or argument type validation (B<Getopt::*> can validate string, 
integer, and floating point argument types).  And while it supports a short 
& long option it doesn't support innumerable aliases in addition.  In 
short, if it isn't explicitly documented it isn't supported, though it 
probably is in B<Getopt::*>.

There are a few restrictions meant to eliminate confusion:

=over

=item 1)

Long and short argument concatenation is only allowed if the argument 
template is '$' (expecting a single argument, only).

=item 2)

Short argument concatenation is furthermore only allowed on arguments 
that aren't allowed to be bundled with other short options.

=item 3) 

Short options supporting bundling can require associate arguments as 
long as '@' is not part of the argument template.

=back

=head1 SUBROUTINES/METHODS

=head2 parseArgs

  $rv = parseArgs(@templates, %opts);
  $rv = parseArgs(@templates, %opts, @args);

Using the option templates passed as the first reference this function 
populates the options hash with all of the parsed options found in the 
passed arguments.  The args list reference can be omitted if you wish the 
function to work off of B<@ARGV>.  Please note that this function makes a
working copy of the array, so no alterations will be made to it.

If any options and/or arguments fail to match the option template, or if 
an option is found with no template, a text message is pushed into an
errors array and the function will return a boolean false.

When the options hash is populated extracted arguments to the options are 
stored in both long and short form as the keys, assuming they were defined 
in the template.  Otherwise it will use whatever form of option was defined.

Any arguments not associated with an option are stored in the options hash 
in a list associated with the key B<PAYLOAD>.  

=head2 Paranoid::Args::listErrors

  @errors = Paranoid::Args::listErrors();

If you need a list of everything that was found wrong during a B<parseArgs>
run, from template errors to command-line argument validation failures, you
can get all of the messages form B<listErrors>.  Please note that we show it
fully qualified because it is B<not> exported.

Each time B<parseArgs> is invoked this array is reset.

=head2 Paranoid::Args::clearMemory

  Paranoid::Args::clearMemory();

If the existence of a (most likely) lightly populated array bothers you, you
may use this function to empty all internal data structures of their contents.
Like B<listErrors> this function is not exported.

=head1 OPTION TEMPLATES

The function provided by this module depends on templates to extract
and validate the options and arguments.  Each option template looks 
similar to the following:

  {
    Short         => 'v',
    Long          => 'verbose',
    Template      => '$',
    CountShort    => 1,
    Multiple      => 1,
    CanBundle     => 1,
    ExclusiveOf   => [],
    AccompaniedBy => [],
  }

This template provides extraction of verbose options in the following (and
similar) forms:

  -vvvvv
  --verbose 5
  --verbose=5

If B<CountShort> was instead false you'd have to say '-v5' or '-v 5' instead 
of '-vvvvv'.

When the B<parseArgs> function is called the options hash passed to it would
be populated with:

  %opts = (
    'v'        => 5,
    'verbose'  => 5,
    );

The redundancy is intentional.  Regardless of whether you look up the short or
the long name you will be able to retrieve the cumulative value.

The particulars of all key/value pairs in a template are documented below.

=head2 Short

B<Short> refers to the form of the short option style (minus the normal
preceding '-').  If this is left undefined then no short option is supported.

This parameter is set to undef by default.

B<NOTE:>  All short option names must be only one character in length and
consisting only of alphanumeric characters.

=head2 Long

B<Long> refers to the from of the long option style (minus the normal 
preceding '--').  If this is left undefined then no long option is 
supported.

This parameter is set to undef by default.

B<NOTE:> All long option names must be more than one character in length and
consisting only of alphanumeric characters and hyphens.

=head2 Template

B<Template> refers to the argument template which informs us how many, if any,
arguments are required for this option.  A template can consist of zero or 
more of the following characters:

  Char  Description
  ========================================================
  $     The option will be followed by a mandatory argument
  @     The option will be followed by one or more arguments
  ''    No additional arguments are expected

For simple boolean options (like '-f') you'd use a zero-length string as the
template.  The associated value of the option will be either a scalar or a
list reference, depending on various parameters in the option template.

If the option has a template of '' then it is assumed that it is a boolean
option.  The associated value in the options hash would then be a scalar:

  # Template: ''
  # @ARGV:  -vvv
  'v' => 3

with the scalar denoting the number of times it was used in the arguments.
It is the same if the template is '$' but CountShort is true.  In that case,
the template really only applies to the long option (whose argument would set
the initial scalar value), while the short options operate purely as an
incrementer.  However, since everything is processed serially, you get the
following results:

  # Template '$', CountShort is true
  # @ARGV: -vvv --verbose=7 -v --verbose=1 -v
  'v' => 2

If the template is '$', but Multiple is false (mandating that the
option be used only once) the associated value is again scalar:

  # Template: '$'
  # @ARGV: -v3
  'v' => 3

If the template is '$' and Multiple is true then the associated value is an
array reference, with the contents of the array being every argument
associated with each option invocation:

  # Template: '$'
  # @ARGV:  --file foo  --file bar
  'file' => [ 'foo', 'bar' ]

If the template is two or more '$' or contains '@' anywhere in the template
then the associated value is an array reference.  The element where '@' would 
occur would be an array reference to the list containing everything globbed 
up by the '@':

  # Template:  '$@'
  # @ARGV: --chmod 0755 foo bar
  'chmod'   => [ '0755', [ 'foo', 'bar' ] ]

If Multiple is true, each element would be a reference to each invocation of 
the option, with the element organized internally as in the previous example:

  # Template: '@'
  # @ARGV:  --add 5 7 2 --add 4 9
  'add'   => [ [ 5, 7, 2 ], [ 4, 9 ] ]

  # Template: '$@$'
  # @ARGV: --perform one two three four --perform five six seven
  'perform' => [ [ 'one', [ 'two', 'three' ], 'four'],
                 [ 'five', [ 'six' ], 'seven' ] ]

NOTE: You cannot use the '@' character if the short option is allowed to be 
bundled with other options.

This parameter defaults to '' (boolean options).

=head2 Multiple

B<Multiple> is a boolean parameter which, if set, allows an option to be used 
more than once on the command-line.

This parameter defaults to false.

=head2 ExclusiveOf

B<ExclusiveOf> is an array of options that this option cannot be used in 
conjunction with.  If the options in this list contain both short and long
names you do not have to list them both.  Listing only one of the names will
suffice.

This parameter defaults to an empty list.

=head2 AccompaniedBy

B<AccompaniedBy> is array of options that this option must be accompanied by.
If the options in this list contain both short and long names you do not 
have to list them both.  Listing only one of the names will suffice.

This parameter defaults to an empty list.

=head2 CanBundle

B<CanBundle> is a boolean parameter which, if set, allows short options to be 
bundled as part of a single argument (i.e., combining '-r' and '-f' as 
'-rf').

This parameter defaults to false.

B<NOTE:> if you wish to be able to concatenate a short option and its
requisite argument then B<CanBundle> must be set to false.

B<NOTE:> if B<CanBundle> is true and each short option requires a mandatory
argument those arguments will be associated with each option in the order in
which the options were specified.  For example, if 'v' and 'S' each expected 
a mandatory single argument:

  -vuS foo bar

v would be associated with foo, and S with bar.  Bundling of short options 
that use '@' as part of their template is not allowed due to the obvious 
guaranteed problems which will result.

=head1 DEPENDENCIES

=over

=item o

L<Paranoid>

=item o

L<Paranoid::Debug>

=back

=head1 EXAMPLE

  @otemplates = (
      {
        Short       => 'v',
        Long        => 'verbose',
        Multiple    => 1,
        CountShort  => 1,
        CanBundle   => 1,
        Template    => '$',
      },
      {
        Short       => 'f',
        Long        => 'force',
        CanBundle   => 1,
        Template    => '',
      },
      {
        Short       => 'h',
        Long        => 'host',
        Multiple    => 1,
        CanBundle   => 1,
        Template    => '$',
      },
    );

  # Process @ARGV:  -vvvfh host1 file1 file2 file3
  if (parseArgs(@otemplates, %opts, @errors)) {
    setVerbosity($opts{'verbose'});

    if ($opts{'force'}) {
      foreach (@{ $opts{'host'} }) {
        if (connectToHost($_)) {
          transferFiles(@{ $opts{'PAYLOAD'} });
        }
      }
    }
  } else {
    foreach (@errors) { warn "$_\n" };
  }

=head1 BUGS AND LIMITATIONS

It is not advisable for you to call B<parseArgs> multiple times in a program to
process a list of arguments in sections.  parseArgs uses an internal flag to
note whether or not its seen the '--' argument, which disables all further
recognition of arguments as options.  That flag is set to false with every
invocation, possibly causing problems for later sections if that flag had been
used in a prior section.

This doesn't offer the same range of functionality or flexibility of
B<Getopt::Long>.

=head1 AUTHOR

Arthur Corliss (corliss@digitalmages.com)

=head1 LICENSE AND COPYRIGHT

This software is licensed under the same terms as Perl, itself. 
Please see http://dev.perl.org/licenses/ for more information.

(c) 2005 - 2017, Arthur Corliss (corliss@digitalmages.com)