package Mojo::DOM::HTML;

use Mojo::Base -base;

use Mojo::Util qw(html_unescape xml_escape);

use Scalar::Util 'weaken';

has 'xml';

has tree => sub { ['root'] };

my $ATTR_RE = qr/

  ([^<>=\s]+)      # Key

  (?:

    \s*=\s*

    (?:

      "([^"]*?)"   # Quotation marks

    |

      '([^']*?)'   # Apostrophes

    |

      ([^>\s]*)    # Unquoted

    )

  )?

  \s*

/x;

my $END_RE   = qr!^\s*/\s*(.+)\s*!;

my $TOKEN_RE = qr/

  ([^<]*)                                           # Text

  (?:

    <\?(.*?)\?>                                     # Processing Instruction

  |

    <!--(.*?)--\s*>                                 # Comment

  |

    <!\[CDATA\[(.*?)\]\]>                           # CDATA

  |

    <!DOCTYPE(

      \s+\w+

      (?:(?:\s+\w+)?(?:\s+(?:"[^"]*"|'[^']*'))+)?   # External ID

      (?:\s+\[.+?\])?                               # Int Subset

      \s*

    )>

  |

    <(

      \s*

      [^<>\s]+                                      # Tag

      \s*

      (?:$ATTR_RE)*                                 # Attributes

    )>

  |

    (<)                                             # Runaway "<"

  )??

/xis;

# HTML elements that break paragraphs

my %PARAGRAPH = map { $_ => 1 } (

  qw(address article aside blockquote dir div dl fieldset footer form h1 h2),

  qw(h3 h4 h5 h6 header hr main menu nav ol p pre section table ul)

);

# HTML table elements with optional end tags

my %TABLE = map { $_ => 1 } qw(colgroup tbody td tfoot th thead tr);

# HTML elements without end tags

my %VOID = map { $_ => 1 } (

  qw(area base br col embed hr img input keygen link menuitem meta param),

  qw(source track wbr)

);

# HTML elements categorized as phrasing content (and obsolete inline elements)

my @PHRASING = (

  qw(a abbr area audio b bdi bdo br button canvas cite code data datalist),

  qw(del dfn em embed i iframe img input ins kbd keygen label link map mark),

  qw(math meta meter noscript object output progress q ruby s samp script),

  qw(select small span strong sub sup svg template textarea time u var video),

  qw(wbr)

);

my @OBSOLETE = qw(acronym applet basefont big font strike tt);

my %PHRASING = map { $_ => 1 } @OBSOLETE, @PHRASING;

sub parse {

  my ($self, $html) = @_;

  my $current = my $tree = ['root'];

  while ($html =~ m/\G$TOKEN_RE/gcs) {

    my ($text, $pi, $comment, $cdata, $doctype, $tag, $runaway)

      = ($1, $2, $3, $4, $5, $6, $11);

    # Text (and runaway "<")

    $text .= '<' if defined $runaway;

    push @$current, ['text', html_unescape $text] if length $text;

    # DOCTYPE

    if ($doctype) { push @$current, ['doctype', $doctype] }

    # Comment

    elsif ($comment) { push @$current, ['comment', $comment] }

    # CDATA

    elsif ($cdata) { push @$current, ['cdata', $cdata] }

    # Processing instruction (try to detect XML)

    elsif ($pi) {

      $self->xml(1) if !defined $self->xml && $pi =~ /xml/i;

      push @$current, ['pi', $pi];

    }

    # End

    next unless $tag;

    my $cs = $self->xml;

    if ($tag =~ $END_RE) { $self->_end($cs ? $1 : lc($1), \$current) }

    # Start

    elsif ($tag =~ m!([^\s/]+)([\s\S]*)!) {

      my ($start, $attr) = ($cs ? $1 : lc($1), $2);

      # Attributes

      my %attrs;

      while ($attr =~ /$ATTR_RE/g) {

        my $key = $cs ? $1 : lc($1);

        my $value = $2 // $3 // $4;

        # Empty tag

        next if $key eq '/';

        $attrs{$key} = defined $value ? html_unescape($value) : $value;

      }

      # Tag

      $self->_start($start, \%attrs, \$current);

      # Element without end tag

      $self->_end($start, \$current)

        if (!$self->xml && $VOID{$start}) || $attr =~ m!/\s*$!;

      # Relaxed "script" or "style"

      if ($start eq 'script' || $start eq 'style') {

        if ($html =~ m!\G(.*?)<\s*/\s*$start\s*>!gcsi) {

          push @$current, ['raw', $1];

          $self->_end($start, \$current);

        }

      }

    }

  }

  return $self->tree($tree);

}

sub render { $_[0]->_render($_[0]->tree) }

sub _close {

  my ($self, $current, $allowed, $scope) = @_;

  # Close allowed parent elements in scope

  my $parent = $$current;

  while ($parent->[0] ne 'root' && $parent->[1] ne $scope) {

    $self->_end($parent->[1], $current) if $allowed->{$parent->[1]};

    $parent = $parent->[3];

  }

}

sub _end {

  my ($self, $end, $current) = @_;

  # Search stack for start tag

  my $found = 0;

  my $next  = $$current;

  while ($next->[0] ne 'root') {

    # Right tag

    ++$found and last if $next->[1] eq $end;

    # Phrasing content can only cross phrasing content

    return if !$self->xml && $PHRASING{$end} && !$PHRASING{$next->[1]};

    $next = $next->[3];

  }

  # Ignore useless end tag

  return unless $found;

  # Walk backwards

  $next = $$current;

  while (($$current = $next) && $$current->[0] ne 'root') {

    $next = $$current->[3];

    # Match

    if ($end eq $$current->[1]) { return $$current = $$current->[3] }

    # Table

    elsif ($end eq 'table') { $self->_close($current, \%TABLE, $end) }

    # Missing end tag

    $self->_end($$current->[1], $current);

  }

}

sub _render {

  my ($self, $tree) = @_;

  # Text (escaped)

  my $e = $tree->[0];

  return xml_escape $tree->[1] if $e eq 'text';

  # Raw text

  return $tree->[1] if $e eq 'raw';

  # DOCTYPE

  return '<!DOCTYPE' . $tree->[1] . '>' if $e eq 'doctype';

  # Comment

  return '<!--' . $tree->[1] . '-->' if $e eq 'comment';

  # CDATA

  return '<![CDATA[' . $tree->[1] . ']]>' if $e eq 'cdata';

  # Processing instruction

  return '<?' . $tree->[1] . '?>' if $e eq 'pi';

  # Start tag

  my $start   = 1;

  my $content = '';

  if ($e eq 'tag') {

    $start = 4;

    # Open tag

    my $tag = $tree->[1];

    $content .= "<$tag";

    # Attributes

    my @attrs;

    for my $key (sort keys %{$tree->[2]}) {

      my $value = $tree->[2]{$key};

      # No value

      push @attrs, $key and next unless defined $value;

      # Key and value

      push @attrs, qq{$key="} . xml_escape($value) . '"';

    }

    my $attrs = join ' ', @attrs;

    $content .= " $attrs" if $attrs;

    # Element without end tag

    return $self->xml || $VOID{$tag} ? "$content />" : "$content></$tag>"

      unless $tree->[4];

    # Close tag

    $content .= '>';

  }

  # Render whole tree

  $content .= $self->_render($tree->[$_]) for $start .. $#$tree;

  # End tag

  $content .= '</' . $tree->[1] . '>' if $e eq 'tag';

  return $content;

}

sub _start {

  my ($self, $start, $attrs, $current) = @_;

  # Autoclose optional HTML elements

  if (!$self->xml && $$current->[0] ne 'root') {

    # "li"

    if ($start eq 'li') { $self->_close($current, {li => 1}, 'ul') }

    # "p"

    elsif ($PARAGRAPH{$start}) { $self->_end('p', $current) }

    # "head"

    elsif ($start eq 'body') { $self->_end('head', $current) }

    # "optgroup"

    elsif ($start eq 'optgroup') { $self->_end('optgroup', $current) }

    # "option"

    elsif ($start eq 'option') { $self->_end('option', $current) }

    # "colgroup", "thead", "tbody" and "tfoot"

    elsif (grep { $_ eq $start } qw(colgroup thead tbody tfoot)) {

      $self->_close($current, \%TABLE, 'table');

    }

    # "tr"

    elsif ($start eq 'tr') { $self->_close($current, {tr => 1}, 'table') }

    # "th" and "td"

    elsif ($start eq 'th' || $start eq 'td') {

      $self->_close($current, {$_ => 1}, 'table') for qw(th td);

    }

    # "dt" and "dd"

    elsif ($start eq 'dt' || $start eq 'dd') {

      $self->_end($_, $current) for qw(dt dd);

    }

    # "rt" and "rp"

    elsif ($start eq 'rt' || $start eq 'rp') {

      $self->_end($_, $current) for qw(rt rp);

    }

  }

  # New tag

  my $new = ['tag', $start, $attrs, $$current];

  weaken $new->[3];

  push @$$current, $new;

  $$current = $new;

}

1;

=encoding utf8

=head1 NAME

Mojo::DOM::HTML - HTML/XML engine

=head1 SYNOPSIS

  use Mojo::DOM::HTML;

  # Turn HTML into DOM tree

  my $html = Mojo::DOM::HTML->new;

  $html->parse('<div><p id="a">A</p><p id="b">B</p></div>');

  my $tree = $html->tree;

=head1 DESCRIPTION

L<Mojo::DOM::HTML> is the HTML/XML engine used by L<Mojo::DOM>.

=head1 ATTRIBUTES

L<Mojo::DOM::HTML> implements the following attributes.

=head2 tree

  my $tree = $html->tree;

  $html    = $html->tree(['root', ['text', 'foo']]);

Document Object Model. Note that this structure should only be used very

carefully since it is very dynamic.

=head2 xml

  my $bool = $html->xml;

  $html    = $html->xml($bool);

Disable HTML semantics in parser and activate case sensitivity, defaults to

auto detection based on processing instructions.

=head1 METHODS

L<Mojo::DOM::HTML> inherits all methods from L<Mojo::Base> and implements the

following new ones.

=head2 parse

  $html = $html->parse('<foo bar="baz">test</foo>');

Parse HTML/XML fragment.

=head2 render

  my $xml = $html->render;

Render DOM to XML.

=head1 SEE ALSO

L<Mojolicious>, L<Mojolicious::Guides>, L<http://mojolicio.us>.

=cut