package SlackBuild::Request;
use strict;
use warnings;
use Carp;
use SlackBuild::URI;
use Text::ParseWords;
use JSON;
use File::Basename;
use Safe;

=head1 NAME

SlackBuild::Request - slackbuild request object

=head1 DESCRIPTION

A request object contains the information necessary for building a
package: the package name, version, URLs of the SlackBuild archive,
etc.

=cut    

=head1 ATTRIBUTES

The following attributes are defined:

=over 4    
    
=item package

Package name (string)

=item version

Package version

=item build

Package build number.

=item slackbuild_uri

URI of the slackbuild archive. It can be a remote URL, a local disk file (tar
archive), or a local directory.

=item source_uri

Array of URIs of the source packages.

=item prereq

Array of prerequisites. Each element is either the package name, or
a hash:

    { package => NAME, [version=>X], [arch=>Y], [build=>Z]) }

See SlackBuild::Registry->lookup.

=item rc

Additional shell code to be run before starting the B<I<package>.SlackBuild>
script.    

=item environ

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.
#   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',
    },
    source_uri => {
	type => 'ARRAY',
	info => 'DOWNLOAD',
	strategy => 'keep'
    },
    prereq => {
	info => 'REQUIRES',
	type => 'ARRAY',
	strategy => 'merge'
    },
    rc => {
	type => 'ARRAY',
    },
    environ => {
	type => 'HASH'
    },
    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;
		   }
	}
    }
);

sub _readfile {
    my ($self,$file) = @_;
    local $/ = undef;
    open(my $fd, $file) or croak "can't open file $file: $!";
    my $string = <$fd>;
    close $fd;
    decode_json($string);
}

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,...)

Build the request from the supplied attribute/value pairs. Allowed attributes
are discussed in detail in the B<ATTRIBUTES> section. Empty argument list
is OK.

    new SlackBuild::Request($file)

Read the request from the disk file B<$file>. The file must contain a single
request formatted as JSON. No empty lines or comments are allowed.    

=cut

sub new {
    my $self = bless {}, shift;
    my %a;
    if (@_ == 1) {
	my $file = shift;
	if (ref($file) eq 'HASH') {
	    %a = %$file;
	} else {
	    %a = %{$self->_readfile($file)}
	}
    } elsif (@_ % 2) {
	croak "bad number of arguments";
    } else {
	%a = @_;
    }
    
    while (my ($k,$v) = each %a) {
	$self->${\ "set_$k"}($v);
    }
    return $self;
}

=head1 STRING REPRESENTATION

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<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 as_string {
    my $self = shift;
    my %h;
    my @k;
    if ($self->string_full) {
	@k = keys %attributes;
    } else {
	@k = grep { defined $self->${\$_} } keys %attributes;
    }
    @h{@k} = map { $self->${\$_} } @k;
    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->as_string };

=head1 MERGING WITH INFO OBJECTS

    $req->addinfo($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} && (my $v = $info->${ \$descr->{info} })) {
	    $self->${\ "set_$attr"}($v);
	}
    }
}

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) {
	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));
	    }
	}
    }
}

sub extract_local_name {
    my ($self, $path) = @_;
    my $result;

    if (my $codelist = $self->local_name) { 
	my $s = new Safe;
	my $package = $self->package;
	my $version = $self->version;
        ${$s->varglob('package')} = $package;
        ${$s->varglob('version')} = $version;
	foreach my $code (@$codelist) {
	    $_ = $path;
	    if (defined(my $r = $s->reval($code))) {
		$result = $_;
		last;
	    } else {
		croak "failed to eval \"$code\" on \"$path\": \n$@\n";
	    }
	}
    }
    return $result || basename($path)
}

1;