sherlock/perl/Object.pm

   1 #       Perl module for manipulating Sherlock objects
   2 #
   3 #       (c) 2007 Martin Mares <mj@ucw.cz>
   4 #
   5 #       This software may be freely distributed and used according to the terms
   6 #       of the GNU Lesser General Public License.
   7
   8 =head1 NAME
   9
  10 Sherlock::Object -- Manipulation with Sherlock objects
  11
  12 =head1 DESCRIPTION
  13
  14 This module offers a simple interface to Sherlock objects. See F<doc/objects>
  15 for a description of how the object system works.
  16
  17 =head1 METHODS
  18
  19 =over
  20
  21 =item B<new()>
  22
  23 Creates a new empty object.
  24
  25 =item B<< new(I<name> => I<value>, ...) >>
  26
  27 Creates a new object with some attributes initialized.
  28
  29 =item B<< set(I<name> => I<value>, ...) >>
  30
  31 Sets given attributes to specified values. If any of the attributes already
  32 exists, the old value is replaced by the new one.
  33
  34 The value can be:
  35
  36 =over
  37
  38 =item *
  39
  40 a number
  41
  42 =item *
  43
  44 a string
  45
  46 =item *
  47
  48 a reference to an array of values, which creates a multi-valued attribute.
  49
  50 =item *
  51
  52 a reference to another object, which created a nested object. In this case
  53 (and only in this case), the name of the attribute must start with C<(>.
  54
  55 =back
  56
  57 =item B<< unset(I<name>, ...) >>
  58
  59 Removes given attributes.
  60
  61 =item B<< add(I<name> => I<value>, ...) >>
  62
  63 Sets given attributes to specified values. If any of the attributes already
  64 exists, the new value is added to the original one, creating a multi-valued
  65 attribute.
  66
  67 The repertoir of values is the same as in the C<set> method except for references
  68 to arrays, which are not allowed.
  69
  70 =item B<< get(I<name>) >>
  71
  72 Gets the value of the given attribute or C<undef> if it does not exist.
  73 If the attribute is multi-valued, the first value is returned.
  74
  75 =item B<< getarray(I<name>) >>
  76
  77 Gets all values of the given attribute as an array or an empty array if the
  78 attribute does not exist.
  79
  80 =item B<< get_attrs() >>
  81
  82 Get an array of names of all attributes present in the object.
  83
  84 =item B<< read(I<handle>) >>
  85
  86 Reads a textual representation of an object from the given handle and adds it
  87 to the object it is invoked on. The effect is the same as calling the C<add>
  88 method on all read attributes.
  89
  90 Returns 1 if the object has been read successfully, 0 if the input
  91 stream ended before an object started or C<undef> if the input was
  92 malformed.
  93
  94 =item B<< read(I<handle>, raw => 1) >>
  95
  96 Reads an object as above, but add a special attribute called C<< RAW >>, which will
  97 contain the raw form of the object.
  98
  99 =item B<< write(I<handle>) >>
 100
 101 Writes a textual representation of the object to the given handle.
 102
 103 =item B<< write_indented(I<handle>, [I<base_indent>]) >>
 104
 105 Writes an indented textual representation of the object to the given handle.
 106 The I<base_indent> will be prepended to all printed lines, each nested level
 107 will get one tab character more.
 108
 109 This is intended for debugging dumps and the output cannot be read back by any
 110 of the Sherlock libraries.
 111
 112 =back
 113
 114 =head1 AUTHOR
 115
 116 Martin Mares <mj@ucw.cz>
 117
 118 =cut
 119
 120 package Sherlock::Object;
 121
 122 use strict;
 123 use warnings;
 124
 125 sub new($@) {
 126         my $self = { };
 127         bless $self;
 128         shift @_;
 129         if (@_) {
 130                 $self->set(@_);
 131         }
 132         return $self;
 133 }
 134
 135 sub set($@) {
 136         my $self = shift @_;
 137         my $attr;
 138         while (defined($attr = shift @_)) {
 139                 $self->{$attr} = shift @_;
 140         }
 141 }
 142
 143 sub unset($@) {
 144         my $self = shift @_;
 145         foreach my $attr (@_) {
 146                 delete $self->{$attr};
 147         }
 148 }
 149
 150 sub add($@) {
 151         my $self = shift @_;
 152         my $attr;
 153         while (defined($attr = shift @_)) {
 154                 my $val = shift @_;
 155                 if (!exists $self->{$attr}) {
 156                         $self->{$attr} = $val;
 157                 } elsif (ref $self->{$attr} eq "ARRAY") {
 158                         push @{$self->{$attr}}, $val;
 159                 } else {
 160                         $self->{$attr} = [ $self->{$attr}, $val ];
 161                 }
 162         }
 163 }
 164
 165 sub get($$) {
 166         my ($self, $attr) = @_;
 167         if (!exists $self->{$attr}) {
 168                 return undef;
 169         } elsif (ref $self->{$attr} eq "ARRAY") {
 170                 return $self->{$attr}->[0];
 171         } else {
 172                 return $self->{$attr};
 173         }
 174 }
 175
 176 sub getarray($$) {
 177         my ($self, $attr) = @_;
 178         if (!exists $self->{$attr}) {
 179                 return ();
 180         } elsif (ref $self->{$attr} eq "ARRAY") {
 181                 return @{$self->{$attr}};
 182         } else {
 183                 return ( $self->{$attr} );
 184         }
 185 }
 186
 187 sub get_attrs($) {
 188         my ($self) = @_;
 189         return keys %$self;
 190 }
 191
 192 sub read($$@) {
 193         my $self = shift @_;
 194         my $fh = shift @_;
 195         my %opts = @_;
 196         my @stack = ();
 197         my $read_something = 0;
 198         my $obj = $self;
 199         my $raw;
 200         my $read = $opts{read} ? $opts{read} : sub { my $fh = shift; return $_ = <$fh>; };
 201         if ($opts{raw}) {
 202                 $raw = $obj->{"RAW"} = [];
 203         }
 204         while ($read->($fh)) {
 205                 chomp;
 206                 /^$/ && last;
 207                 my ($a, $v) = /^(.)(.*)$/ or return undef;
 208                 push @$raw, $_ if $raw;
 209                 if ($a eq "(") {
 210                         $a = "$a$v";
 211                         my $new = new Sherlock::Object;
 212                         $obj->add($a, $new);
 213                         push @stack, $obj;
 214                         $obj = $new;
 215                 } elsif ($a eq ")") {
 216                         @stack or return undef;
 217                         $obj = pop @stack;
 218                 } else {
 219                         $obj->add($a, $v);
 220                 }
 221                 $read_something = 1;
 222         }
 223         @stack and return undef;
 224         return $read_something;
 225 }
 226
 227 sub write($$) {
 228         my ($self, $fh) = @_;
 229         foreach my $a (keys %$self) {
 230                 my $vals = $self->{$a};
 231                 ref $vals eq "ARRAY" or $vals = [$vals];
 232                 foreach my $v (@{$vals}) {
 233                         if (ref $v eq "") {
 234                                 print $fh $a, $v, "\n";
 235                         } elsif (ref $v eq "Sherlock::Object") {
 236                                 print $fh $a, "\n";
 237                                 $v->write($fh);
 238                                 print $fh ")\n";
 239                         } else {
 240                                 die;
 241                         }
 242                 }
 243         }
 244 }
 245
 246 sub write_indented($$$) {
 247         my ($self, $fh, $indent) = @_;
 248         defined $indent or $indent = "";
 249         foreach my $a (sort keys %$self) {
 250                 my $vals = $self->{$a};
 251                 ref $vals eq "ARRAY" or $vals = [$vals];
 252                 foreach my $v (@{$vals}) {
 253                         if (ref $v eq "") {
 254                                 print $fh $indent, $a, $v, "\n";
 255                         } elsif (ref $v eq "Sherlock::Object") {
 256                                 print $fh $indent, $a, "\n";
 257                                 $v->write_indented($fh, $indent . "\t");
 258                                 print $fh $indent, ")\n";
 259                         } else {
 260                                 die;
 261                         }
 262                 }
 263         }
 264 }
 265
 266 1;  # OK