package Prty::Section::Object;
use base qw/Prty::Object/;

use strict;
use warnings;
use utf8;

our $VERSION = 1.093;

# -----------------------------------------------------------------------------

=encoding utf8

=head1 NAME

Prty::Section::Object - Abschnitts-Objekt

=head1 BASE CLASS

L<Prty::Object>

=head1 DESCRIPTION

Ein Objekt der Klasse repräsentiert einen "Abschnitt". Abschnitte werden
von C<< Prty::Section::Parser >> geparst und instantiiert.

Ein Abschnittsobjekt gibt Auskunft über den Inhalt des Abschnitts
und dessen "Ort" (Dateiname und Zeilennummer). Das Objekt ist readonly,
d.h. die Objekteigenschaften können gelesen aber nicht gesetzt werden.

=head1 METHODS

=head2 Konstruktor

=head3 new() - Konstruktor

=head4 Synopsis

    $sec = $class->new($type,$keyValH);
    $sec = $class->new($type,$keyValH,$keyA,$content,$source,$file,$line);

=head4 Arguments

=over 4

=item $type

Abschnitts-Typ einschließlich Klammern (sofern vorhanden).

=item $keyValH

Referenz auf Schlüssel/Wert-Hash.

=item $keyA

Referenz auf Schlüssel-Array.

=item $content

Inhalt.

=item $source

Quelltext des Abschnitts.

=item $file

Name der Datei, die den Abschnitt enthält. Im Falle einer
In-Memory-Datei ist der Dateiname "C<(source)>".

=item $line

Zeilennummer, an der der Abschnitt in der Datei beginnt.

=back

=head4 Returns

Referenz auf Abschnitts-Objekt

=head4 Description

Instantiiere ein Abschnittsobjekt und liefere eine Referenz
auf das Objekt zurück.

=cut

# -----------------------------------------------------------------------------

sub new {
    my ($class,$type,$keyValH,$keyA,$content,$source,$file,$line) = @_;

    # Abschnittsbezeichner in eigentlichen Bezeichner und
    # Klammerung zerlegen

    my $brackets = '';
    if ($type =~ /^(\W)(\w+)(\W)$/) {
        $type = $2;
        $brackets = "$1$3";
    }

    if (!defined $keyA) {
        $keyA = [keys %$keyValH];
    }

    if (!defined $content) {
        $content = '';
    }
    if (!defined $source) {
        $source = '';
    }
    if (!defined $file) {
        $file = '(internal)';
    }
    if (!defined $line) {
        $line = 0;
    }

    # Objekt instantiieren

    return bless [
        $type,        # [0]
        $brackets,    # [1]
        $keyA,        # [2]
        $keyValH,     # [3]
        $content,     # [4]
        $source,      # [5]
        $file,        # [6]
        $line,        # [7]
    ],$class;
}

# -----------------------------------------------------------------------------

=head2 Akzessoren

=head3 type() - Liefere/Setze Abschnittsbezeichner

=head4 Synopsis

    $type = $sec->type;
    $type = $sec->type($type);

=head4 Returns

Abschnittsbezeichner (String)

=head4 Description

Liefere den Abschnittsbezeichner. Ist Parameter $type angegeben, setze
den Abschnittsbezeichner auf diesen Wert.

=cut

# -----------------------------------------------------------------------------

sub type {
    my $self = shift;
    # @_: $type

    if (@_) {
        $self->[0] = shift;
    }
    
    return $self->[0];
}

# -----------------------------------------------------------------------------

=head3 brackets() - Liefere Klammerung

=head4 Synopsis

    $brackets = $sec->brackets;
    $brackets = $sec->brackets($brackets);

=head4 Returns

Klammerpaar (String)

=head4 Description

Liefere die Klammerung um den Abschnittsbezeichner, sofern vorhanden.
Ist der Abschnittsbezeichner nicht geklammert, liefere einen Leerstring.
Ist Parameter $brackets angegeben, setze die Klammerung auf diesen Wert.

=head4 Details

Die Klamerung um den Abschnitts-Bezeichner ist optional.
Sie besteht aus der öffnenden und schließenden Klammer,
ist also "[]", "<>" oder "()" oder "{}".

=cut

# -----------------------------------------------------------------------------

sub brackets {
    my $self = shift;
    # @_: $type

    if (@_) {
        $self->[1] = shift;
    }
    
    return $self->[1];
}

# -----------------------------------------------------------------------------

=head3 keys() - Liefere die Liste der Schlüssel

=head4 Synopsis

    $keyA|@keys = $sec->keys;

=head4 Description

Liefere die Liste der Schlüssel. Im Skalarkontext liefere eine
Referenz auf die Liste.

=cut

# -----------------------------------------------------------------------------

sub keys {
    my $self = shift;
    return wantarray? @{$self->[2]}: $self->[2];
}

# -----------------------------------------------------------------------------

=head3 keyValHash() - Liefere den Attributhash

=head4 Synopsis

    $hash|@arr = $sec->keyValHash;

=head4 Returns

Im Sklarkontext liefere eine Referenz auf den Attribut-Hash.
Im Arraykontext liefere die Liste der Attribut/Wert-Paare.

=cut

# -----------------------------------------------------------------------------

sub keyValHash {
    my $self = shift;
    return wantarray? %{$self->[3]}: $self->[3];
}

# -----------------------------------------------------------------------------

=head3 content() - Liefere/Setze Inhalt

=head4 Synopsis

    $content = $sec->content;
    $content = $sec->content($content);

=head4 Returns

Inhalt (String)

=cut

# -----------------------------------------------------------------------------

sub content {
    my $self = shift;

    if (@_) {
        $self->[4] = shift;
    }

    return $self->[4];
}

# -----------------------------------------------------------------------------

=head3 contentRef() - Liefere Referenz auf den Inhalt

=head4 Synopsis

    $ref = $sec->contentRef;

=head4 Returns

Referenz auf Inhalt (String-Referenz)

=cut

# -----------------------------------------------------------------------------

sub contentRef {
    return \shift->[4];
}

# -----------------------------------------------------------------------------

=head3 contentNL() - Liefere Inhalt mit Newline

=head4 Synopsis

    $contentN = $sec->contentNL;

=head4 Returns

Inhalt mit Newline (String)

=cut

# -----------------------------------------------------------------------------

sub contentNL {
    my $self = shift;
    return $self->[4] eq ''? '': $self->[4]."\n";
}

# -----------------------------------------------------------------------------

=head3 source() - Liefere Quelltext

=head4 Synopsis

    $source = $sec->source;

=head4 Returns

Quelltext (String)

=cut

# -----------------------------------------------------------------------------

sub source {
    return shift->[5];
}

# -----------------------------------------------------------------------------

=head3 removeEofMarker() - Entferne "# eof" vom Quelltext und vom Content

=head4 Synopsis

    $sec->removeEofMarker;

=head4 Returns

nichts

=cut

# -----------------------------------------------------------------------------

sub removeEofMarker {
    my $self = shift;
    $self->[4] =~ s/\s+# eof\n*$//;
    $self->[5] =~ s/\n# eof\n*$/\n/;
    return;
}

# -----------------------------------------------------------------------------

=head3 deleteSource() - Lösche Quelltext

=head4 Synopsis

    $sec->deleteSource;

=head4 Returns

nichts

=cut

# -----------------------------------------------------------------------------

sub deleteSource {
    shift->[5] = undef;
    return;
}

# -----------------------------------------------------------------------------

=head3 file() - Liefere Dateiname

=head4 Synopsis

    $file = $sec->file;

=head4 Returns

Dateiname (String)

=cut

# -----------------------------------------------------------------------------

sub file {
    return shift->[6];
}

# -----------------------------------------------------------------------------

=head3 line() - Liefere Zeilennummer

=head4 Synopsis

    $n = $sec->line;

=head4 Returns

Zeilennummer (Integer)

=cut

# -----------------------------------------------------------------------------

sub line {
    return shift->[7];
}

# -----------------------------------------------------------------------------

=head3 fileInfo() - Liefere Dateiname und Zeilennummer in einem Aufruf

=head4 Synopsis

    ($file,$line) = $sec->fileInfo;

=head4 Returns

Dateiname (String) und Zeilennummer (Integer)

=cut

# -----------------------------------------------------------------------------

sub fileInfo {
    my $self = shift;
    return ($self->[6],$self->[7]);
}

# -----------------------------------------------------------------------------

=head2 Attribute

=head3 get() - Liefere Wert zu Schlüssel

=head4 Synopsis

    $val = $sec->get($key);
    @vals = $sec->get(@keys);

=head4 Arguments

=over 4

=item $key bzw. @keys

Schlüssel, deren Wert geliefert wird.

=back

=head4 Returns

Wert (Skalar-Kontext) oder Wertliste (Array-Kontext)

=head4 Description

Liefere den Wert zu Schlüssel $key bzw. die liste der Werte zu den
Schlüsseln @keys. Beginnt der $key mit einem Großbuchstaben, ist
es ein fataler Fehler, wenn zu dem Schlüssel mehrere Werte existieren.
Solche Schlüssel müssen mit $obj->getArray() abgefragt werden.

=cut

# -----------------------------------------------------------------------------

sub get {
    my $self = shift;
    # @_: $key -or- @keys

    my @arr;
    while (@_) {
        my $key = shift;

        my $val = $self->[3]->{$key};
        if (ref($val) && $key =~ /^[A-Z]/) {
            $self->throw(
                q{SECOBJ-00001: Schlüssel besitzt mehrere Werte},
                Key=>$key,
                Values=>'['.join(',',@$val).']',
            );
        }
        push @arr,$val;
    }
    
    return wantarray? @arr: $arr[0];
}

# -----------------------------------------------------------------------------

=head3 getArray() - Liefere Wertliste zu Schlüssel

=head4 Synopsis

    $arr|@arr = $sec->getArray($key);

=head4 Arguments

=over 4

=item $key

Schlüssel dessen Wertliste geliefert wird.

=back

=head4 Returns

Wert bzw. Werte

=head4 Description

Liefere die Wertliste von Schlüssel $key.

=cut

# -----------------------------------------------------------------------------

sub getArray {
    my ($self,$key) = @_;

    my $s = $self->[3]->{$key};
    if (ref $s) {
        return wantarray? @$s: $s;
    }
    elsif (defined $s && $s ne '') {
        return wantarray? ($s): [$s];
    }
    else {
        return wantarray? (): [];
    }
}

# -----------------------------------------------------------------------------

=head3 getBool() - Liefere boolschen Wert zu Schlüssel

=head4 Synopsis

    $bool = $sec->getBool($key);
    $bool = $sec->getBool($key,$default);

=head4 Arguments

=over 4

=item $key

Schlüssel, dessen Wert geliefert wird.

=item $default

Defaultwert, wenn Attribut nicht gesetzt

=back

=head4 Returns

Wert (Skalar)

=head4 Description

Liefere boolschen Wert zu Schlüssel $key.

=cut

# -----------------------------------------------------------------------------

sub getBool {
    my ($self,$key,$default) = @_;

    my $val = lc($self->get($key) // $default // '');
    if ($val eq '' || $val eq 'no' || $val eq '0') {
        $val = 0;
    }
    elsif ($val eq 'yes' || $val eq '1') {
        $val = 1;
    }
    else {
        $self->throw(
            q{COTEDO-00001: Illegal attribute value. Only Yes/No allowed.},
            Attribute=>$key,
            Value=>$val,
            File=>$self->file,
            Line=>$self->line,
            -stacktrace=>0,
        );
    }

    return $val;
}

# -----------------------------------------------------------------------------

=head3 getMandatory() - Liefere Wert eines Pflichtattributs

=head4 Synopsis

    $val = $sec->getMandatory($key);

=head4 Arguments

=over 4

=item $key

Schlüssel, dessen Wert geliefert wird.

=back

=head4 Returns

Wert (Skalar)

=head4 Description

Wie $sec->get(), nur dass ein Wert existieren muss, sonst
wird eine Exception geworfen.

=cut

# -----------------------------------------------------------------------------

sub getMandatory {
    my ($self,$key) = @_;

    my $val = $self->get($key);
    if (!defined $val || $val eq '') { 
        $self->throw(
            q{SECOBJ-00002: Attribute has no value},
            Key=>$key,
            File=>$self->file,
            Line=>$self->line,
            -stacktrace=>0,
        );
    }

    return $val;
}

# -----------------------------------------------------------------------------

=head3 getRef() - Liefere Referenz auf Schlüsselwert

=head4 Synopsis

    $ref = $sec->getRef($key);

=cut

# -----------------------------------------------------------------------------

sub getRef {
    my ($self,$key) = @_;
    return \$self->[3]->{$key};
}

# -----------------------------------------------------------------------------

=head3 try() - Werte abfragen ohne Exception

=head4 Synopsis

    $val = $sec->try($key);
    @vals = $sec->try(@keys);

=head4 Description

Wie get(), nur dass im Falle eines unerlaubten Schlüssels
keine Exception geworfen, sondern C<undef> geliefert wird.

=cut

# -----------------------------------------------------------------------------

sub try {
    my ($self,$key) = @_;
    return $self->[3]->try($key);
}

# -----------------------------------------------------------------------------

=head3 memoize() - Ermittele Wert und cache ihn auf Attribut

=head4 Synopsis

    $val = $sec->memoize($key,$sub);

=head4 Description

Die Methode liefert den Wert des Attributs $key. Ist kein Wert
definiert (Wert ist C<undef>), wird die Methode $sec->$sub($key)
gerufen, der Wert berechnet und auf dem Attribut $key gespeichert.
Weitere Aufrufe liefern diesen Wert, ohne dass er neu berechnet wird.

Die Methode ist nützlich, um in Objektmethoden eingebettet zu werden,
die einen berechneten Wert liefern, der nicht immer wieder neu
gerechnet werden soll.

=head4 Example

    sub name {
        return shift->memoize('name',sub {
            my ($self,$key) = @_;
            my $name = $self->get(ucfirst $key);
            $name =~ s/^\W+//;
            $name =~ s|\W+|/|g;
            return $name;
        });
    }

=cut

# -----------------------------------------------------------------------------

sub memoize {
    my ($self,$key,$sub) = @_;

    my $val = $self->[3]->{$key};
    if (!defined $val) {
        $val = $self->$sub($key);
        $self->[3]->{$key} = $val;
    }

    return $val;
}

# -----------------------------------------------------------------------------

=head3 memoizeWeaken() - Ermittele schwache Referenz

=head4 Synopsis

    $val = $sec->memoizeWeaken($key,$sub);

=head4 Description

Die Methode ist identisch zu $sec->memoize(), nur dass eine
Referenz ermittelt und automatisch zu einer schwachen Referenz
gemacht wird.

=cut

# -----------------------------------------------------------------------------

sub memoizeWeaken {
    my ($self,$key,$sub) = @_;

    my $val = $self->[3]->{$key};
    if (!defined $val) {
        $val = $self->$sub($key);
        $self->[3]->{$key} = $val;
        $self->[3]->weaken($key);
    }

    return $val;
}

# -----------------------------------------------------------------------------

=head3 set() - Setze Schlüssel auf Wert

=head4 Synopsis

    $sec->set(@keyVal);

=head4 Arguments

=over 4

=item @keyVal

Schlüssel/Wert-Paare, die gesetzt werden.

=back

=head4 Returns

nichts

=cut

# -----------------------------------------------------------------------------

sub set {
    my $self = shift;
    # @_: @keyVal
    $self->[3]->set(@_);
    return;
}

# -----------------------------------------------------------------------------

=head3 setDefault() - Setze Defaultwert

=head4 Synopsis

    $sec->setDefault(@keyVal);

=head4 Arguments

=over 4

=item @keyVal

Liste der Schlüssel/Wert-Paare.

=back

=head4 Returns

I<nichts>

=head4 Description

Setze Schlüssel ohne Wert, d.h. wenn der Wert ein Leerstring ist,
setze ihn auf den angegebenen Defaultwert.

=head4 Example

    $sec->setDefault(
        Width=>1000,
        EntityMenuWidth=>345,
        BorderWidth=>1,
        PackageMenuHeight=>34,
    );

=cut

# -----------------------------------------------------------------------------

sub setDefault {
    my $self = shift;
    # @_: @keyVal

    my $h = $self->[3];
    for (my $i = 0; $i < @_; $i += 2) {
        if ($h->{$_[$i]} eq '') {
            $h->{$_[$i]} = $_[$i+1];
        }
    }

    return;
}

# -----------------------------------------------------------------------------

=head3 push() - Füge Element zu Arraykomponente hinzu

=head4 Synopsis

    $sec->push($key,$val);

=head4 Arguments

=over 4

=item $key

Arraykomponente.

=item $val

Wert, der zum Array am Ende hinzugefügt wird.

=back

=head4 Description

Füge Wert $val zur Arraykomponente $key hinzu. Die Methode liefert keinen
Wert zurück.

=cut

# -----------------------------------------------------------------------------

sub push {
    my ($self,$key,$val) = @_;
    CORE::push @{$self->[3]->{$key}},$val;
    return;
}

# -----------------------------------------------------------------------------

=head3 weaken() - Erzeuge schwache Referenz

=head4 Synopsis

    $ref = $sec->weaken($key);
    $ref = $sec->weaken($key=>$ref);

=head4 Description

Mache die Referenz von Schlüssel $key zu einer schwachen Referenz
und liefere sie zurück. Ist eine Referenz $ref als Parameter angegeben,
setze die Referenz zuvor.

=cut

# -----------------------------------------------------------------------------

sub weaken {
    return shift->[3]->weaken(@_);
}

# -----------------------------------------------------------------------------

=head3 validate() - Prüfe und ergänze Attribute

=head4 Synopsis

    $sec->validate($contentAllowed,\@keys);

=head4 Arguments

=over 4

=item $contentAllowed

Wenn falsch, erlaubt der Abschnitt keinen Content (außer "# eof"
als Dateiende-Markierung).

=item @keys

Liste der zulässigen Abschnittsattribute

=back

=head4 Returns

Nichts

=head4 Description

Die Methode finalisiert das Abschnittsobjekt in folgender Weise:

=over 2

=item *

Sie prüft, dass wenn kein Content erlaubt ist, keiner existiert.

=item *

Sie prüft, dass nur Schlüssel im Objekt vorkommen, die in @keys
vorkommen. Kommt ein anderer Schlüssel im Objekt vor, wird eine
Exception geworfen.

=item *

Sie fügt Schlüssel aus @keys zum Objekt hinzu, die das Objekt nicht hat.

=back

=cut

# -----------------------------------------------------------------------------

sub validate {
    my $self = shift;
    my $contentAllowed = shift;
    my $keyA = shift; # erlaubte Attribute

    # Prüfung Content

    if (!$contentAllowed && $self->[4] ne '' && $self->[4] ne '# eof') {
        $self->throw(
            q{SECTION-00001: Inhalt ist nicht erlaubt},
            Section=>$self->type,
            Content=>$self->[4],
            File=>$self->file,
            Line=>$self->line,
            -stacktrace=>0,
        );
    }

    # Prüfung/Ergänzung Attribute

    my $h = $self->[3];
    for my $key (@$keyA) {
        if (!exists $h->{$key}) {
            $h->{$key} = '';
        }
    }

    if ($h->hashSize > @$keyA) {
        # Wenn im Hash mehr Schlüssel als erwartet vorkommen,
        # fehlerhafte Schlüssel ermitteln und Exception werfen

        my %h;
        @h{@$keyA} = (1) x @$keyA;
        my @keys;
        for my $key ($self->keys) {
            if (!exists $h{$key}) {
                CORE::push @keys,$key,
            }
        }
        $self->throw(
            q{SECTION-00001: Unknown section attribute},
            Section=>$self->type,
            Key=>join(', ',@keys),
            File=>$self->file,
            Line=>$self->line,
            -stacktrace=>0,
        );
    }

    return;
}

# -----------------------------------------------------------------------------

=head3 lockKeys() - Locke die Keys des Attribut-Hash

=head4 Synopsis

    $sec->lockKeys;

=cut

# -----------------------------------------------------------------------------

sub lockKeys {
    my $self = shift;
    $self->[3]->lockKeys;
    return;
}

# -----------------------------------------------------------------------------

=head2 Automatische Akzessor-Methoden

=head3 AUTOLOAD() - Erzeuge Akzessor-Methode

=head4 Synopsis

    $val = $this->AUTOLOAD;
    $val = $this->AUTOLOAD($val);

=head4 Description

Erzeuge beim ersten Aufruf eine Akzessor-Methode für einen Schlüssel
des Schlüssel/Wert-Hashs und führe den betreffenden Methodenaufruf
durch.

=cut

# -----------------------------------------------------------------------------

sub AUTOLOAD {
    my $this = shift;
    # @_: Methodenargumente

    my ($key) = our $AUTOLOAD =~ /::(\w+)$/;
    return if $key !~ /[^A-Z]/;

    # Klassenmethoden generieren wir nicht

    if (!ref $this) {
        $this->throw(
            q{HASH-00002: Klassen-Methode existiert nicht},
            Method=>$key,
        );
    }

    # Methode nur generieren, wenn Attribut existiert

    if (!exists $this->[3]->{$key}) {
        $this->throw(
            q{HASH-00001: Schlüssel existiert nicht},
            Attribute=>$key,
            Class=>ref($this)? ref($this): $this,
        );
    }

    # Attribut-Methode generieren. Wenn der Hash $self->[3] gelockt ist,
    # führt ein unerlaubter Zugriff zu einer Exception.

    no strict 'refs';
    *{$AUTOLOAD} = sub {
        my $self = shift;
        # @_: $val

        if (@_) {
            return $self->[3]->{$key} = shift;
        }

        return $self->[3]->{$key};
    };

    # Methode aufrufen
    return $this->$key(@_);
}

# -----------------------------------------------------------------------------

=head1 VERSION

1.093

=head1 AUTHOR

Frank Seitz, L<http://fseitz.de/>

=head1 COPYRIGHT

Copyright (C) 2016 Frank Seitz

=head1 LICENSE

This code is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut

# -----------------------------------------------------------------------------

1;

# eof
