### ----------------------------------------------------
### -- LibXML
### -- Licenses: Artistic-2.0
### -- Authors: David Warring
### -- File: lib/LibXML/Config.rakumod
### ----------------------------------------------------
use v6.d;
use OO::Monitors;
#| LibXML Global configuration
unit monitor LibXML::Config;

=begin pod

=head2 Synopsis

  =begin code :lang<raku>
  use LibXML::Config;
  if  LibXML::Config.have-compression { ... }

  # change global default for maximum errors
  LibXML::Config.max-errors = 42;

  # create a parser with its own configuration
  my LibXML::Config:D $config .= new: :max-errors(100);
  my LibXML::Parser:D $parser .= new: :$config;
  my LibXML::Document:D $doc = $parser.parse: :html, :file<messy.html>;
  =end code

=head2 Description

This class holds configuration settings. Some of which are read-only. Others are
writeable, as listed below.

In the simple case, the global configuration can be updated to suit the application.

Objects of type L<LibXML::Config> may be created to enable configuration to localised and more explicit.

Note however that the `input-callbacks` and `external-entity-loader` are global in the `libxml`
library and need to be configured globally:

=begin code :lang<raku>
LibXML::Config.input-callbacks = @input-callbacks;
LibXML::Config.external-entity-loader = &external-entity-loader;
=end code

...or `parser-locking` needs to be set, which allows multiple local configurations,
but disables multi-threaded parsing:

=begin code :lang<raku>
LibXML::Config.parser-locking = True;
my LibXML::Config $config .= new: :@input-callbacks, :&external-entity-loader;
=end code


Configuration instance objects may be passed to objects that perform the `LibXML::_Configurable` role,
including L<LibXML>, L<LibXML::Parser>, L<LibXML::_Reader>.

    =for code :lang<raku>
    my $doc = LibXML.parse: :file<doc.xml>, :$config;

DOM objects, generally aren't configurable, although some particular methods do support a `:$config` option.

- L<LibXML::Document> methods: `processXIncludes`, `validate`, `Str`, `Blob`, and `parse`.
- L<LibXML::Element> method: `appendWellBalancedChunk`.
- L<LibXML::Node> methods: `ast` and `xpath-class`.

=end pod

use LibXML::Enums;
use LibXML::Raw;
use LibXML::Types :resolve-package;
use LibXML::X;
use NativeCall;

# XXX Temporary solution for testing where no specific config object is required
my LibXML::Config:D $singleton .= new;
method global { $singleton }

proto method clone(|) {*}
multi method clone(::?CLASS:U: |c) { $singleton.clone(|c) }
multi method clone(::?CLASS:D: |c) { nextsame }

=head2 Configuration Methods

#| Returns the run-time version of the `libxml2` library.
my $version;
method version(--> Version:D) {
    return $_ with ⚛$version;
    cas $version, { $_ // try { Version.new(xmlParserVersion.match(/^ (.) (..) (..) /).join: '.'); } // do { self.config-version } };
}

#| Returns the version of the `libxml2` library that the LibXML module was built against
my $config-version;
method config-version(--> Version:D) {
    $config-version //= Version.new: xml6_config::version()
}

#| Returns True if the `libxml2` library supports XML Reader (LibXML::Reader) functionality.
my $have-reader;
method have-reader(--> Bool:D) {
    $have-reader //= resolve-package('LibXML::Reader').have-reader
}

#| Returns True if the `libxml2` library supports XML Writer (LibXML::Writer) functionality.
my $have-writer;
method have-writer(--> Bool:D) {
    $have-writer //= try { resolve-package('LibXML::Writer').have-writer } // False;
}
=para Note: LibXML::Writer is available as a separate module.

#| Returns True if the `libxml2` library supports XML Schema (LibXML::Schema) functionality.
my $have-schemas;
method have-schemas(--> Bool:D) {
    $have-schemas //= do given self.version {
        $_ >= v2.05.10 && $_ != v2.09.04
    }
}

#| Returns True if the `libxml2` library supports threads
my $have-threads;
method have-threads(--> Bool:D) { $have-threads //= ? xml6_config::have_threads(); }

#| Returns True if the `libxml2` library supports compression
my $have-compression;
method have-compression(--> Bool:D) { $have-compression //= ? xml6_config::have_compression(); }

#| Returns True if the `libxml2` library supports iconv (unicode encoding)
my $have-iconv;
method have-iconv(--> Bool:D) { $have-iconv //= ? xml6_config::have_iconv(); }

my $catalogs = SetHash.new;
method load-catalog(Str:D $filename --> Nil) {
    my Int $stat = 0;
    unless $filename ∈ $catalogs {
        $stat = xmlLoadCatalog($filename);
        fail "unable to load XML catalog: $filename"
            if $stat < 0;
        $catalogs.set: $filename;
    }
}

=head2 Serialization Default Options

# -- Output options --

=head3 method skip-xml-declaration
=for code :lang<raku>
method skip-xml-declaration() is rw returns Bool
=para Whether to omit '<?xml ...>' preamble (default False)

has Bool:D() $!skip-xml-declaration is built = False;

proto method skip-xml-declaration() {*}
multi method skip-xml-declaration(::?CLASS:U: --> Bool:D) is rw { $singleton.skip-xml-declaration }
multi method skip-xml-declaration(::?CLASS:D: --> Bool:D) is rw { $!skip-xml-declaration }

=head3 method skip-dtd
=for code :lang<raku>
method skip-dtd() is rw returns Bool
=para Whether to omit internal DTDs (default False)

has Bool:D() $!skip-dtd is built = False;

proto method skip-dtd() {*}
multi method skip-dtd(::?CLASS:U: --> Bool) is rw { $singleton.skip-dtd }
multi method skip-dtd(::?CLASS:D: --> Bool) is rw { $!skip-dtd }

#| Whether to output empty tags as '<a></a>' rather than '<a/>' (default False)
has Bool:D() $!tag-expansion is built = False;

proto method tag-expansion() {*}
multi method tag-expansion(::?CLASS:U: --> Bool) is rw { $singleton.tag-expansion }
multi method tag-expansion(::?CLASS:D: --> Bool) is rw { $!tag-expansion }

=head3 method max-errors
=for code :lang<raku>
method max-errors() is rw returns Int:D
=para Maximum errors before throwing a fatal X::LibXML::TooManyErrors

has UInt:D $!max-errors is built = 100;

proto method max-errors() {*}
multi method max-errors(::?CLASS:U: --> UInt:D) is rw { $singleton.max-errors }
multi method max-errors(::?CLASS:D: --> UInt:D) is rw { $!max-errors }

=head2 Parsing Default Options

has xmlDocumentType:D $!document-kind = XML_DOCUMENT_NODE;

proto method document-kind() {*}
multi method document-kind(::?CLASS:U: --> xmlDocumentType:D) { $singleton.document-kind }
multi method document-kind(::?CLASS:D: --> xmlDocumentType:D) { $!document-kind }

method keep-blanks-default is rw is DEPRECATED<keep-blanks> { $.keep-blanks }
method default-parser-flags is DEPRECATED<parser-flags> { $.parser-flags }

has &!external-entity-loader;

proto method external-entity-loader() {*}
multi method external-entity-loader(::?CLASS:U:) is rw { $singleton.external-entity-loader }
multi method external-entity-loader(::?CLASS:D:) is rw {
    Proxy.new(
        FETCH => { &!external-entity-loader },
        STORE => -> $, &loader {
            if self === $singleton {
                set-external-entity-loader(&loader);
            }
            &!external-entity-loader = &loader;
        });
}

proto method setup(|) {*}
multi method setup(::?CLASS:U: --> List:D) { $singleton.setup }
multi method setup(::?CLASS:D: --> List:D) {
    if self.defined && &!external-entity-loader.defined && !self.parser-locking {
        warn q:to<END>.chomp;
        Unsafe use of local 'external-entity-loader' configuration.
        Please configure globally, or set 'parser-locking' to disable threaded parsing
        END
    }
    my @prev[4] = (
        $*THREAD.id,
        xml6_gbl::get-tag-expansion(),
        xml6_gbl::get-keep-blanks(),
        xml6_gbl::get-external-entity-loader,
    );
    xml6_gbl::set-tag-expansion(self.tag-expansion);
    xml6_gbl::set-keep-blanks(self.keep-blanks);
#    xml6_gbl::set-external-entity-loader(&!external-entity-loader) with self && &!external-entity-loader;
    if self !=== $singleton && &!external-entity-loader {
        note "SETTING EXTERNAL ENT LOADER";
        set-external-entity-loader(&!external-entity-loader);
    }
    @prev;
}

multi method restore([]) { }
multi method restore(@prev where .elems == 4) {
    if $*THREAD.id == @prev[0] {
        xml6_gbl::set-tag-expansion(@prev[1]);
        xml6_gbl::set-keep-blanks(@prev[2]);
        xml6_gbl::set-external-entity-loader(@prev[3]) with self;
    }
    else {
        warn "OS thread change\n" ~ Backtrace.new.full.Str.indent(4);
    }
}

has Bool:D() $!keep-blanks is built = True;

proto method keep-blanks() {*}
multi method keep-blanks(::?CLASS:U: --> Bool) is rw { $singleton.keep-blanks }
multi method keep-blanks(::?CLASS:D: --> Bool) is rw { $!keep-blanks }

#| Low-level default parser flags (Read-only)
method parser-flags(--> UInt:D) {
    XML_PARSE_NONET
    + XML_PARSE_NODICT
    + ($.keep-blanks ?? 0 !! XML_PARSE_NOBLANKS)
}

#| External entity handler to be used when parser expand-entities is set.
sub set-external-entity-loader(&loader) {
    my constant XML_CHAR_ENCODING_NONE = 0;
    if &loader.defined {
        xmlExternalEntityLoader::Set(
            sub (Str $url, Str $id, xmlParserCtxt $ctxt --> xmlParserInput) {
                CATCH {
                    default {
                        if $ctxt.defined {
                            $ctxt.ParserError(.message);
                        }
                        else {
                            note "uncaught entity loader error: " ~ .message;
                        }
                        return xmlParserInput;
                    }
                }
                my Str $string := &loader($url, $id);
                my xmlParserInputBuffer $buf .= new: :$string;
                $ctxt.NewInputStream($buf, XML_CHAR_ENCODING_NONE);
            }
        );
    }
}

=para The routine provided is called whenever the parser needs to retrieve the
    content of an external entity. It is called with two arguments: the system ID
    (URI) and the public ID. The value returned by the subroutine is parsed as the
    content of the entity. 

=para This method can be used to completely disable entity loading, e.g. to prevent
    exploits of the type described at  (L<http://searchsecuritychannel.techtarget.com/generic/0,295582,sid97_gci1304703,00.html>), where a service is tricked to expose its private data by letting it parse a
   remote file (RSS feed) that contains an entity reference to a local file (e.g. C</etc/fstab>).

=para This method acts globally across all parser instances and threads.

=para A more granular and localised solution to this problem, however, is provided by
custom URL resolvers, as in
        =begin code :lang<raku>
        my LibXML::InputCallback $cb .= new;
        sub match($uri) {   # accept file:/ URIs except for XML catalogs in /etc/xml/
          my ($uri) = @_;
          ? ($uri ~~ m|^'file:/'}
             and $uri !~~ m|^'file:///etc/xml/'|)
        }
        sub deny(|c) { }
        $cb.register-callbacks(&match, &deny, &deny, &deny);
        $parser.input-callbacks($cb)
        =end code

=head3 method input-callbacks
=for code :lang<raku>
method input-callbacks is rw returns LibXML::InputCallback
=para Default input callback handlers.

=para The LibXML::Config:U `input-callbacks` method sets and enables a set of input callbacks for the entire
process.

=para The  LibXML::Config:U `input-callbacks` sets up a localised set of input callbacks.
Concurrent use of multiple input callbacks is NOT thread-safe and `parser-locking`
also needs to be set to disable concurrent parsing (see below).

has $!input-callbacks is built;

proto method input-callbacks(|) {*}
multi method input-callbacks(::?CLASS:U:) is rw { $singleton.input-callbacks }
multi method input-callbacks(::?CLASS:D:) is rw {
    Proxy.new(
        FETCH => sub ($) { $!input-callbacks },
        STORE => sub ($, $callbacks) {
            if self === $singleton {
                .deactivate with $!input-callbacks;
                .activate with $callbacks;
            }
            $!input-callbacks = $callbacks
        });
}
=para See L<LibXML::InputCallback>

=head3 parser-locking
=para This configuration setting will lock the parsing of documents to disable
concurrent parsing. It needs to be set to allow per-parser input-callbacks,
which are not currently thread safe.

my Bool:D() $parser-locking = $*DISTRO.is-win || ! $singleton.have-threads;
method parser-locking is rw { $parser-locking }

=para Note: `parser-locking` defaults to `True` on Windows, as some platforms have thread-safety issues.

=head2 Query Handler

my subset QueryHandler where .can('query-to-xpath').so;

my QueryHandler $query-handler = class NoQueryHandler {
    method query-to-xpath($) {
        fail "query-handler has not been configured";
    }
}

method lock handles<protect> {
    # global lock
    BEGIN Lock.new;
}

sub protected(&action) is hidden-from-backtrace is export(:protected) {
    $parser-locking
        ?? $singleton.protect(&action)
        !! &action();
}


=head3 method query-handler
=for code :lang<raku>
method query-handler() is rw returns LibXML::Config::QueryHandler
=para Default query handler to service querySelector() and querySelectorAll() methods

has $!query-handler is built = $query-handler;

proto method query-handler() {*}
multi method query-handler(::?CLASS:U: --> QueryHandler) is rw { $singleton.query-handler }
multi method query-handler(::?CLASS:D: --> QueryHandler) is rw { $!query-handler }
=para See L<LibXML::XPath::Context>

my constant @DefaultClassMap =
    'LibXML::Attr'             => XML_ATTRIBUTE_NODE,
    'LibXML::CDATA'            => XML_CDATA_SECTION_NODE,
    'LibXML::Comment'          => XML_COMMENT_NODE,
    'LibXML::Dtd'              => XML_DTD_NODE,
    'LibXML::Dtd::AttrDecl'    => XML_ATTRIBUTE_DECL,
    'LibXML::Dtd::ElementDecl' => XML_ELEMENT_DECL,
    'LibXML::Dtd::Entity'      => XML_ENTITY_DECL,
    'LibXML::DocumentFragment' => XML_DOCUMENT_FRAG_NODE,
    'LibXML::Document'         => XML_HTML_DOCUMENT_NODE,
    'LibXML::Document'         => XML_DOCB_DOCUMENT_NODE,
    'LibXML::Document'         => XML_DOCUMENT_NODE,
    'LibXML::Element'          => XML_ELEMENT_NODE,
    'LibXML::EntityRef'        => XML_ENTITY_REF_NODE,
    'LibXML::Namespace'        => XML_NAMESPACE_DECL,
    'LibXML::PI'               => XML_PI_NODE,
    'LibXML::Text'             => XML_TEXT_NODE;

my constant %DefaultClassMap = @DefaultClassMap;
my constant @ClassMap = do {
    my Str @map;
    for @DefaultClassMap -> (:key($class-name), :value($code)) {
        @map[$code] = $class-name;
    }
    @map;
}
my constant %RawClassType =
    @LibXML::Raw::ClassMap.pairs.map({ @LibXML::Raw::ClassMap[.key]:exists ?? (.value.^name => .key) !! Empty });

has @!class-map is default(Nil);

proto method class-map() {*}
multi method class-map(::?CLASS:U:) { $singleton.class-map }
multi method class-map(::?CLASS:D:) {
    unless @!class-map {
        @!class-map = @ClassMap.map({ .defined ?? resolve-package($_) !! Nil })
    }
    @!class-map
}

method !validate-map-class-name(Str:D $class, Str:D $why, Bool:D :$strict = True) {
    %DefaultClassMap{$class}:exists
        || ($strict ?? X::LibXML::ClassName.new(:$class, :$why).throw !! False)
}

method !validate-map-class(Any:U \type, Str:D $why, Bool:D :$strict = True) {
    %DefaultClassMap{type.^name}:exists
        || ($strict ?? X::LibXML::Class.new(:class(type.^name), :$why).throw !! False)
}

proto method map-class(|) {*}
multi method map-class(::?CLASS:U: |c) { $singleton.map-class(|c) }
multi method map-class(::?CLASS:D: Int:D $id, Mu:U \user-type) {
    @.class-map[$id] := user-type;
}
multi method map-class(::?CLASS:D: Str:D $class, Mu:U \user-type) {
    self!validate-map-class-name($class, q<unknown to configuration 'map-call' method>);
    samewith(%DefaultClassMap{$class}, user-type);
}
multi method map-class(::?CLASS:D: LibXML::Types::Itemish:U \from-type, Mu:U \user-type) {
    self!validate-map-class(from-type, q<unsupported by configuration 'map-call' method>);
    samewith(from-type.^name, user-type)
}
# Maps LibXML::* class names into user classes
multi method map-class(::?CLASS:D: *@pos, *%mappings) {
    for %mappings.kv -> Str:D $class, \user-type {
        samewith(%DefaultClassMap{$class}, user-type);
    }

    for @pos -> $mapping {
        unless $mapping ~~ Pair {
            X::LibXML::ArgumentType.new(:got($mapping.WHAT),
                :expected(Pair),
                :routine(q<configuration method 'map-class'>)).throw;
        }
        samewith($mapping.key, $mapping.value);
    }
}

proto method class-from($) {*}
multi method class-from(::?CLASS:U: |c) is raw { $singleton.class-from(|c) }
multi method class-from(::?CLASS:D: LibXML::Types::Itemish:U \from-type, Bool:D :$strict = True) is raw {
    return from-type
        unless self!validate-map-class(
            from-type,
            q<unsupported by configuration 'class-from' method>,
            :$strict);
    samewith(%DefaultClassMap{from-type.^name});
}
multi method class-from(::?CLASS:D: Str:D $class, Bool:D :$strict = True) is raw {
    return resolve-package($class)
        unless self!validate-map-class-name(
            $class,
            q<unknown to configuration 'class-from' method>,
            :$strict);
    samewith(%DefaultClassMap{$class});
}
multi method class-from(::?CLASS:D: Int:D $id) is raw { @.class-map[$id] }
multi method class-from(::?CLASS:D: anyNode:D $raw) is raw { @.class-map[$raw.type] }
multi method class-from(::?CLASS:D: Any:U \raw-type, Bool:D :$strict = True) {
    my $raw-name = raw-type.^name;
    %RawClassType{$raw-name}:exists
        ?? @.class-map[ %RawClassType{$raw-name} ]
        !! ($strict
            ?? X::LibXML::Class.new(:class($raw-name), :why(q<unknown to configuration method 'class-from'>)).throw
            !! Nil)
}

#| Enable object re-use per XML node.
has Bool:D $.with-cache is built = False;

has %!node-cache;
has Lock:D $!cache-lock .= new;

proto method box(|) {*}
multi method box(::?CLASS:D: anyNode:D $raw, &vivify? is copy, *%profile) {
    &vivify //= sub { self.class-from($raw).bless: :raw($raw.delegate), |%profile }
    return &vivify() unless $!with-cache;
    $!cache-lock.protect: {
        %!node-cache{$raw.unique-key} //= &vivify();
    }
}
multi method box(::?CLASS:D: Any:U \raw-type, &vivify) {
    my $raw-name = raw-type.^name;
    %RawClassType{$raw-name}:exists
        ?? self.class-from(%RawClassType{$raw-name})
        !! (&vivify
            ?? vivify()
            !! X::LibXML::Class.new(:class($raw-name), :why(q<unknown to configuration method 'box'>)).throw)
}
multi method box(::?CLASS:U: |c) {
    $singleton.box: |c
}


=begin pod

=head2 Copyright

2001-2007, AxKit.com Ltd.

2002-2006, Christian Glahn.

2006-2009, Petr Pajas.

=head2 License

This program is free software; you can redistribute it and/or modify it under
the terms of the Artistic License 2.0 L<http://www.perlfoundation.org/artistic_license_2_0>.

=end pod


