← Back to branch summary

~johnemb/randgen/xml-report

« back to all changes in this revision

Viewing changes to lib/GenTest/Properties.pm

  • Committer: Bernt M. Johnsen
  • Date: 2009-11-20 10:29:35 UTC
  • mto: (140.3.6 rqg-bernt)
  • mto: This revision was merged to the branch mainline in revision 157.
  • Revision ID: bernt.johnsen@sun.com-20091120102935-yldf173mresd20b3
New config

Show diffs side-by-side

added added

removed removed

Lines of Context:
lib/GenTest/Properties.pm
 
1
package GenTest::Properties;
 
2
 
 
3
@ISA = qw(GenTest);
 
4
 
 
5
use strict;
 
6
use Carp;
 
7
use GenTest;
 
8
use GenTest::Constants;
 
9
 
 
10
use Data::Dumper;
 
11
 
 
12
use constant PROPS_NAME => 0;
 
13
use constant PROPS_DEFAULTS => 1; ## Default values
 
14
use constant PROPS_OPTIONS => 2;  ## Legal options to check for
 
15
use constant PROPS_HELP => 3;     ## Help text
 
16
use constant PROPS_LEGAL => 4;    ## List of legal properies
 
17
use constant PROPS_LEGAL_HASH => 5; ## Hash of legal propertis
 
18
use constant PROPS_PROPS => 6;    ## the actual properties
 
19
 
 
20
1;
 
21
 
 
22
sub AUTOLOAD {
 
23
    my $self = shift;
 
24
    my $name = our $AUTOLOAD;
 
25
    $name =~ s/.*:://;
 
26
    
 
27
    return unless $name =~ /[^A-Z]/;
 
28
    
 
29
    if (defined $self->[PROPS_LEGAL]) {
 
30
        croak("Illegal property '$name' for ". $self->[PROPS_NAME]) 
 
31
            if not $self->[PROPS_LEGAL_HASH]->{$name};
 
32
    }
 
33
    
 
34
    return $self->[PROPS_PROPS]->{$name};
 
35
}
 
36
 
 
37
sub new {
 
38
    my $class = shift;
 
39
    
 
40
        my $props = $class->SUPER::new({
 
41
        'name' => PROPS_NAME,
 
42
        'defaults'      => PROPS_DEFAULTS,
 
43
        'options' => PROPS_OPTIONS,
 
44
        'legal' => PROPS_LEGAL,
 
45
        'help' => PROPS_HELP}, @_);
 
46
    
 
47
    ## List of legal properties, if no such list, 
 
48
    ## all properties are legal
 
49
    
 
50
    if (defined $props->[PROPS_LEGAL]) {
 
51
        foreach my $legal (@{$props->[PROPS_LEGAL]}) {
 
52
            $props->[PROPS_LEGAL_HASH]->{$legal}=1;
 
53
        }
 
54
    }
 
55
    
 
56
    if (defined $props->[PROPS_OPTIONS]) {
 
57
        foreach my $legal (keys %{$props->[PROPS_OPTIONS]}) {
 
58
            $props->[PROPS_LEGAL_HASH]->{$legal}=1;
 
59
        }
 
60
    }
 
61
    if (defined $props->[PROPS_DEFAULTS]) {
 
62
        foreach my $legal (keys %{$props->[PROPS_DEFAULTS]}) {
 
63
            $props->[PROPS_LEGAL_HASH]->{$legal}=1;
 
64
        }
 
65
    }
 
66
    
 
67
    my $defaults = $props->[PROPS_DEFAULTS];
 
68
    $defaults = {} if not defined $defaults;
 
69
    
 
70
    my $from_cli = $props->[PROPS_OPTIONS];
 
71
    $from_cli = {} if not defined $from_cli;
 
72
    
 
73
    my $from_file = {};
 
74
    
 
75
    if ($from_cli->{config}) {
 
76
        $from_file = _readProps($from_cli->{config},$props->[PROPS_LEGAL_HASH]);
 
77
    }
 
78
    
 
79
    $props->[PROPS_PROPS] = _mergeProps($defaults, $from_file);
 
80
    $props->[PROPS_PROPS] = _mergeProps($props->[PROPS_PROPS], $from_cli);
 
81
    
 
82
    return $props;
 
83
}
 
84
 
 
85
sub _readProps {
 
86
    my ($file,$legal) = @_;
 
87
    open(PFILE, $file) or die "Unable read properties file '$file': $!";
 
88
    read(PFILE, my $propfile, -s $file);
 
89
    close PFILE;
 
90
    my $props = eval($propfile);
 
91
    croak "Unable to load $file: $@" if $@;
 
92
    my $illegal = 0;
 
93
    foreach my $p (keys %$props) {
 
94
        if (not $legal->{$p}) {
 
95
            carp "'$p' is not a legal property";
 
96
            $illegal = 1;
 
97
        }
 
98
    }
 
99
    if ($illegal) {
 
100
        croak "Illegal properties";
 
101
    }
 
102
    return $props;
 
103
}
 
104
 
 
105
sub _mergeProps {
 
106
    my ($a,$b) = @_;
 
107
    
 
108
    # First recursively deal with hashes
 
109
    my $mergedHashes = {};
 
110
    foreach my $h (keys %$a) {
 
111
        if (UNIVERSAL::isa($a->{$h},"HASH")) {
 
112
            if (defined $b->{$h}) {
 
113
                $mergedHashes->{$h} = _mergeProps($a->{$h},$b->{$h});
 
114
            }
 
115
        }
 
116
    }
 
117
    # The merge
 
118
    my $result = {%$a, %$b};
 
119
    $result = {%$result,  %$mergedHashes};
 
120
    return $result;
 
121
}
 
122
 
 
123
sub printProps {
 
124
    my ($self) = @_;
 
125
    _printProps($self->[PROPS_PROPS]);
 
126
}
 
127
 
 
128
sub _printProps {
 
129
    my ($props,$indent) = @_;
 
130
    $indent = 1 if not defined $indent;
 
131
    my $x = join(" ", map {undef} (1..$indent*3));
 
132
    foreach my $p (sort keys %$props) {
 
133
        if (UNIVERSAL::isa($props->{$p},"HASH")) {
 
134
            say ($x .$p." => ");
 
135
            _printProps($props->{$p}, $indent+1);
 
136
        } elsif  (UNIVERSAL::isa($props->{$p},"ARRAY")) {
 
137
        say ($x .$p." => ['".join("', '",@{$props->{$p}})."']");
 
138
        } else {
 
139
            say ($x.$p." => ".$props->{$p});
 
140
        }
 
141
    }
 
142
}
 
143
 
 
144
sub _purgeProps {
 
145
    my ($props) = @_;
 
146
    my $purged = {};
 
147
    foreach my $key (keys %$props) {
 
148
        $purged->{$key} = $props->{$key} if defined $props->{$key};
 
149
    }
 
150
    return $purged;
 
151
}
 
152
 
 
153
sub _assertProps {
 
154
    my ($props, @list) = @_;
 
155
    foreach my $p (@list) {
 
156
        croak "Required property '$p' not set" if not exists $props->{$p};
 
157
    }
 
158
}
 
159
 
 
160
sub genOpt {
 
161
    my ($self, $prefix, $options) = @_;
 
162
 
 
163
    my $hash;
 
164
    if (UNIVERSAL::isa($options,"HASH")) {
 
165
        $hash = $options;
 
166
    } else {
 
167
        $hash = $self->$options;
 
168
    }
 
169
    
 
170
    return join(' ', map {$prefix.$_.(defined $hash->{$_}?
 
171
                                      ($hash->{$_} eq ''?
 
172
                                       '':'='.$hash->{$_}):'')} keys %$hash);
 
173
}
 
174
 
 
175
1;