Introduce strategies for merging Slackware info files into build requests

Three strategies are defined:

  1. keep      - request attribute takes precedence over the info one
  2. overwrite - info attribute takes precedence ovet the request one
  3. merge     - both atributes are merged (only for HASH and ARRAY
                 attributes).

Strategies can be defined using the "strategy" request keyword. Default
strategy is "keep" for all attributes, excepting "prereq", for which the
default is "merge".

* lib/SlackBuild/Info.pm (new): Ignore trailing whitespace.
Don't return silently on syntax errors.
(str): Rename to as_string. Make sure keys are in lexical order.
* lib/SlackBuild/Request.pm: Major rewrite. Introduce new attribute
"strategy" - a hash defining merging strategy for request attributes.
(str): Rename to as_string. Make sure keys are in lexical order.

* t/info.t: Update.
* t/request.t: Update.

2 files changed, 209 insertions, 48 deletions

diff --git a/lib/SlackBuild/Info.pm b/lib/SlackBuild/Info.pm
index 28daf73..4f1c1f1 100644
--- a/lib/SlackBuild/Info.pm
+++ b/lib/SlackBuild/Info.pm
@@ -64,6 +64,7 @@ sub new {
 	}
 	while (<$fd>) {
 	    chomp;
+	    s/\s+$//;
 	    if (/\\$/) {
 		chop;
 		$_ .= <$fd>;
@@ -71,7 +72,8 @@ sub new {
 	    }
 	    s/^\s+//;
 	    next if /^(#.*)?$/;
-	    return unless /^(?<kw>[A-Za-z_][A-Za-z_0-9]*)="(?<val>.*)"$/;
+	    croak "bad input line: $_"
+		unless /^(?<kw>[A-Za-z_][A-Za-z_0-9]*)="(?<val>.*)"$/;
 	    if (exists($attributes{$+{kw}})) {
 		$self->${\$+{kw}}($+{val});
 	    } else {
@@ -123,15 +125,15 @@ representation is returned by the B<str> method.
 
 =cut
 
-sub str {
+sub as_string {
     my $self = shift;
     my %h;
-    my @k = sort keys %attributes;
+    my @k = keys %attributes;
     @h{@k} = map { $self->${\$_} } @k;
-    encode_json(\%h);
+    JSON->new->canonical(1)->encode(\%h);
 }
 
-use overload '""' => sub { shift->str };
+use overload '""' => sub { shift->as_string };
 
 {
     no strict 'refs';
diff --git a/lib/SlackBuild/Request.pm b/lib/SlackBuild/Request.pm
index 53d1e16..ca113d5 100644
--- a/lib/SlackBuild/Request.pm
+++ b/lib/SlackBuild/Request.pm
@@ -66,31 +66,59 @@ script.
 Shell environment variables for the B<I<package>.SlackBuild> script. Variables
 VERSION and BUILD are set from the corresponding attributes.    
 
+=item local_name
+
+A perl expression for obtaining local file name from the URL of the source
+archive. By default, the last directory component of the URL pathname is
+taken as the local file name for download.    
+
+=item strategy
+
+A hash defining merging strategy for certain attributes. See the section
+B<MERGING WITH INFO OBJECTS> below for a detailed discussion.    
+
+=item string_full
+
+A boolean value indicating whether the string representation of the object
+should include attributes with B<null> value.    
+    
 =back
     
 =cut    
 
 # Hash of attributes this object has. Keys are attribute names. Values
 # are hashrefs, that can have the following keys:
+#   type - Type of the attribute - 'SCALAR', 'ARRAY' or 'HASH'. Mandatory.
 #   info - Name of the SlackBuild::Info attribute corresponding to that
 #          attribute.
-#   type - Type of the attribute - either 'ARRAY' or 'HASH'
+#   strategy - default merge strategy for this attribute.
+
 my %attributes = (
     package => {
+	type => 'SCALAR',
 	info => 'PRGNAM',
+	strategy => 'keep'
     },
     version => {
+	type => 'SCALAR',
 	info => 'VERSION',
+	strategy => 'keep'
+    },
+    build => {
+	type => 'SCALAR',
+    },
+    slackbuild_uri => {
+	type => 'SCALAR',
     },
-    build => {},
-    slackbuild_uri => {},
     source_uri => {
-	info => 'DOWNLOAD',
 	type => 'ARRAY',
+	info => 'DOWNLOAD',
+	strategy => 'keep'
     },
     prereq => {
 	info => 'REQUIRES',
 	type => 'ARRAY',
+	strategy => 'merge'
     },
     rc => {
 	type => 'ARRAY',
@@ -100,6 +128,74 @@ my %attributes = (
     },
     local_name => {
 	type => 'ARRAY'
+    },
+    strategy => {
+	type => 'HASH'
+    }
+);
+
+# Values for STRATEGY:
+#   overwrite   New value always overrides the old one
+#   keep        Old value takes precedence
+#   merge       old and new values are merged.
+
+my %generics = (
+    'SCALAR' => {
+	get => sub {
+	           my ($self, $attr) = @_;
+		   return $self->{$attr};
+	},
+	set => sub {
+	           my ($self, $attr, $value, $strat) = @_;
+		   if (defined($self->{$attr}) && defined($strat)
+		       && $strat ne 'overwrite') {
+		       ; # Nothing
+		   } else {
+		       $self->{$attr} = $value;
+		   }
+	}
+    },
+    'HASH' => {
+	get => sub {
+	           my ($self, $attr) = @_;
+	           return $self->{$attr};
+	},
+ 	set => sub {
+	           my ($self, $attr, $value, $strat) = @_;
+		   croak "hashref expected" unless ref($value) eq 'HASH';
+		   if (defined($self->{$attr}) && defined($strat)
+		       && $strat ne 'keep') {
+		       if ($strat eq 'merge') {
+			   $self->{attr} = [ %{$self->{attr}}, %{$value} ];
+		       }
+		   } else {
+		       $self->{$attr} = $value;
+		   }
+	}
+    }, 
+    'ARRAY' => {
+	get => sub {
+	           my ($self, $attr) = @_;
+	           return $self->{$attr};
+	},
+ 	set => sub {
+	           my ($self, $attr, $value, $strat) = @_;
+		   my $t = ref($value);
+		   if ($t eq '') {
+		       $value = [ $value ];
+		   } elsif ($t ne 'ARRAY') {
+		       croak "arrayref or scalar expected";
+		   }
+		   if (defined($self->{$attr}) && defined($strat)) {
+		       if ($strat eq 'overwrite') {
+			   $self->{$attr} = $value;
+		       } elsif ($strat eq 'merge') {
+			   push @{$self->{$attr}}, @{$value};
+		       }
+		   } else {
+		       $self->{$attr} = $value;
+		   }
+	}
     }
 );
 
@@ -112,7 +208,31 @@ sub _readfile {
     decode_json($string);
 }
 
-=head1 COSNTRUCTOR
+sub strategy {
+    my ($self, $attr) = @_;
+    if ($attr) {
+	if (exists($self->{strategy}) && exists($self->{strategy}{$attr})) {
+	    return $self->{strategy}{$attr};
+	}
+	return $attributes{$attr}{strategy} || 'keep';
+    }
+    return $self->{strategy}
+}
+
+sub set_strategy {
+    my ($self, $value) = @_;
+    croak "hashref expected" unless ref($value) eq 'HASH';
+    foreach my $key (keys %$value) {
+	croak "$key: undefined attribute"
+	    unless exists $attributes{$key};
+	unless (grep { $value->{$key} eq $_ } qw{overwrite keep merge}) {
+	    croak $value->{key} . ": unknown merge strategy";
+	}
+    }
+    $self->{strategy} = $value;
+}
+
+=head1 CONSTRUCTOR
 
     new SlackBuild::Request(ATTR => VALUE,...)
 
@@ -144,7 +264,7 @@ sub new {
     }
     
     while (my ($k,$v) = each %a) {
-	$self->${\$k}($v);
+	$self->${\ "set_$k"}($v);
     }
     return $self;
 }
@@ -153,73 +273,112 @@ sub new {
 
 When used is string context, objects of this class are represented as
 JSON objects with attribute names sorted in lexical order. The same
-representation is returned by the B<str> method.    
+representation is returned by the B<as_string> method.
+
+If the B<string_full> attribute is set, the string representation
+includes all attributes, including the ones with B<null> value. Otherwise,
+only non-null attributes are returned (the default).
 
 =cut    
     
-sub str {
+sub as_string {
     my $self = shift;
     my %h;
-    my @k = sort keys %attributes;
+    my @k;
+    if ($self->string_full) {
+	@k = keys %attributes;
+    } else {
+	@k = grep { defined $self->${\$_} } keys %attributes;
+    }
     @h{@k} = map { $self->${\$_} } @k;
-    encode_json(\%h);
+    JSON->new->canonical(1)->encode(\%h);
+}
+
+sub string_full {
+    my $self = shift;
+    if (my $v = shift) {
+	croak "too many arguments" if @_;
+	$self->{string_full} = $v;
+    }
+    return $self->{string_full};
+}
+
+sub set_string_full {
+    my ($self, $value) = @_;
+    $self->{string_full} = $value;
 }
 
-use overload '""' => sub { shift->str };
+use overload '""' => sub { shift->as_string };
 
 =head1 MERGING WITH INFO OBJECTS
 
     $req->addinfo($info)
 
-Fills in the missing attributes from the SlackBuild::Info object B<$info>.
+Merges B<$info> (an instance of B<SlackBuild::Info>) with the request
+object B<$req>.
+
+If an attribute is unset in B<$req>, it will be set from the corresponding
+field in B<$req>.
+
+Otherwise, the behavior depends on the merging strategy set for that
+attribute:
+
+=over 4
 
+=item overwrite
+
+The value from B<$info> always overwrites the B<$req> attribute.
+
+=item keep
+
+If the attribute is set, its value is retained and the B<$info> field
+is ignored.
+
+=item merge
+
+If the attribute is C<HASH> or C<ARRAY>, the B<$info> field is merged in
+the attribute.
+
+=back    
+
+The default strategy is B<merge> for B<prereq>, and B<keep> for the rest
+of attributes.    
+    
 =cut
 
 sub addinfo {
     my ($self, $info) = @_;
     while (my ($attr,$descr) = each %attributes) {
-	if ($descr->{info} && !defined($self->${\$attr}) &&
-	    (my $v = $info->${ \$descr->{info} })) {
-	    $self->${\$attr}($v);
+	if ($descr->{info} && (my $v = $info->${ \$descr->{info} })) {
+	    $self->${\ "set_$attr"}($v);
 	}
     }
 }
 
-sub prereq {
-    my $self = shift;
-    croak "too many arguments" if @_ > 1;
-    if (my $v = shift) {
-	$v = [ $v ] unless ref($v) eq 'ARRAY';
-	$v = [ grep { $_ ne '%README%' } @$v ];
-	$self->{prereq} = $v;
-    }
-    return $self->{prereq};
+sub set_prereq {
+    my ($self, $value) = @_;
+    my $meth = $generics{ARRAY}{set};
+    $value = [ $value ] unless ref($value) eq 'ARRAY';
+    $value = [ grep { $_ ne '%README%' } @$value ];
+    $self->${\$meth}('prereq', $value, $self->strategy('prereq'));
 }
 
 {
     no strict 'refs';
     use feature 'state';
     while (my ($attr,$descr) = each %attributes) {
-	next if __PACKAGE__->can($attr);
-	*{ __PACKAGE__ . '::' . $attr } = sub {
-	    my $self = shift;
-	    croak "too many arguments" if @_ > 1;
-	    if (my $v = shift) {
-		if ($descr->{type}) {
-		    if (my $r = ref($v)) {
-			croak "$attr must be $descr->{type}"
-			    unless $r eq $descr->{type};
-		    } elsif ($descr->{type} eq 'ARRAY') {
-			$v = [ $v ];
-		    } elsif ($descr->{type} eq 'HASH') {
-			croak "$attr must be $descr->{type}"
-		    } else {
-			croak "unhandled data type for $attr: $descr->{type}; please report";
-		    }
-		}
-		$self->{$attr} = $v;
+	unless (__PACKAGE__->can($attr)) {
+	    *{ __PACKAGE__ . '::' . $attr } = sub {
+		my $self = shift;
+		return $self->${ \ $generics{$descr->{type}}{get} }($attr);
+	    }
+	}
+	unless (__PACKAGE__->can("set_$attr")) {
+	    *{ __PACKAGE__ . '::set_' . $attr } = sub {
+		my ($self, $value) = @_;
+		$self->${\$generics{$descr->{type}}{set}}
+                       ($attr, $value, $self->strategy($attr));
 	    }
-	    return $self->{$attr};
 	}
     }
 }