+++ /dev/null
-package DOM::Tiny::_CSS;
-
-use strict;
-use warnings;
-
-our $VERSION = '0.004';
-
-my $ESCAPE_RE = qr/\\[^0-9a-fA-F]|\\[0-9a-fA-F]{1,6}/;
-my $ATTR_RE = qr/
- \[
- ((?:$ESCAPE_RE|[\w\-])+) # Key
- (?:
- (\W)?= # Operator
- (?:"((?:\\"|[^"])*)"|'((?:\\'|[^'])*)'|([^\]]+?)) # Value
- (?:\s+(i))? # Case-sensitivity
- )?
- \]
-/x;
-
-sub new {
- my $class = shift;
- bless @_ ? @_ > 1 ? {@_} : {%{$_[0]}} : {}, ref $class || $class;
-}
-
-sub tree {
- my $self = shift;
- return $self->{tree} unless @_;
- $self->{tree} = shift;
- return $self;
-}
-
-sub matches {
- my $tree = shift->tree;
- return $tree->[0] ne 'tag' ? undef : _match(_compile(shift), $tree, $tree);
-}
-
-sub select { _select(0, shift->tree, _compile(@_)) }
-sub select_one { _select(1, shift->tree, _compile(@_)) }
-
-sub _ancestor {
- my ($selectors, $current, $tree, $one, $pos) = @_;
-
- while ($current = $current->[3]) {
- return undef if $current->[0] eq 'root' || $current eq $tree;
- return 1 if _combinator($selectors, $current, $tree, $pos);
- last if $one;
- }
-
- return undef;
-}
-
-sub _attr {
- my ($name_re, $value_re, $current) = @_;
-
- my $attrs = $current->[2];
- for my $name (keys %$attrs) {
- next unless $name =~ $name_re;
- return 1 unless defined $attrs->{$name} && defined $value_re;
- return 1 if $attrs->{$name} =~ $value_re;
- }
-
- return undef;
-}
-
-sub _combinator {
- my ($selectors, $current, $tree, $pos) = @_;
-
- # Selector
- return undef unless my $c = $selectors->[$pos];
- if (ref $c) {
- return undef unless _selector($c, $current);
- return 1 unless $c = $selectors->[++$pos];
- }
-
- # ">" (parent only)
- return _ancestor($selectors, $current, $tree, 1, ++$pos) if $c eq '>';
-
- # "~" (preceding siblings)
- return _sibling($selectors, $current, $tree, 0, ++$pos) if $c eq '~';
-
- # "+" (immediately preceding siblings)
- return _sibling($selectors, $current, $tree, 1, ++$pos) if $c eq '+';
-
- # " " (ancestor)
- return _ancestor($selectors, $current, $tree, 0, ++$pos);
-}
-
-sub _compile {
- my $css = "$_[0]";
- $css =~ s/^\s+//;
- $css =~ s/\s+$//;
-
- my $group = [[]];
- while (my $selectors = $group->[-1]) {
- push @$selectors, [] unless @$selectors && ref $selectors->[-1];
- my $last = $selectors->[-1];
-
- # Separator
- if ($css =~ /\G\s*,\s*/gc) { push @$group, [] }
-
- # Combinator
- elsif ($css =~ /\G\s*([ >+~])\s*/gc) { push @$selectors, $1 }
-
- # Class or ID
- elsif ($css =~ /\G([.#])((?:$ESCAPE_RE\s|\\.|[^,.#:[ >~+])+)/gco) {
- my ($name, $op) = $1 eq '.' ? ('class', '~') : ('id', '');
- push @$last, ['attr', _name($name), _value($op, $2)];
- }
-
- # Attributes
- elsif ($css =~ /\G$ATTR_RE/gco) {
- push @$last, [
- 'attr', _name($1),
- _value(
- defined($2) ? $2 : '',
- defined($3) ? $3 : defined($4) ? $4 : $5,
- $6
- ),
- ];
- }
-
- # Pseudo-class
- elsif ($css =~ /\G:([\w\-]+)(?:\(((?:\([^)]+\)|[^)])+)\))?/gcs) {
- my ($name, $args) = (lc $1, $2);
-
- # ":not" (contains more selectors)
- $args = _compile($args) if $name eq 'not';
-
- # ":nth-*" (with An+B notation)
- $args = _equation($args) if $name =~ /^nth-/;
-
- # ":first-*" (rewrite to ":nth-*")
- ($name, $args) = ("nth-$1", [0, 1]) if $name =~ /^first-(.+)$/;
-
- # ":last-*" (rewrite to ":nth-*")
- ($name, $args) = ("nth-$name", [-1, 1]) if $name =~ /^last-/;
-
- push @$last, ['pc', $name, $args];
- }
-
- # Tag
- elsif ($css =~ /\G((?:$ESCAPE_RE\s|\\.|[^,.#:[ >~+])+)/gco) {
- push @$last, ['tag', _name($1)] unless $1 eq '*';
- }
-
- else {last}
- }
-
- return $group;
-}
-
-sub _empty { $_[0][0] eq 'comment' || $_[0][0] eq 'pi' }
-
-sub _equation {
- return [0, 0] unless my $equation = shift;
-
- # "even"
- return [2, 2] if $equation =~ /^\s*even\s*$/i;
-
- # "odd"
- return [2, 1] if $equation =~ /^\s*odd\s*$/i;
-
- # "4", "+4" or "-4"
- return [0, $1] if $equation =~ /^\s*((?:\+|-)?\d+)\s*$/;
-
- # "n", "4n", "+4n", "-4n", "n+1", "4n-1", "+4n-1" (and other variations)
- return [0, 0]
- unless $equation =~ /^\s*((?:\+|-)?(?:\d+)?)?n\s*((?:\+|-)\s*\d+)?\s*$/i;
- return [$1 eq '-' ? -1 : !length $1 ? 1 : $1, join('', split(' ', $2 || 0))];
-}
-
-sub _match {
- my ($group, $current, $tree) = @_;
- _combinator([reverse @$_], $current, $tree, 0) and return 1 for @$group;
- return undef;
-}
-
-sub _name {qr/(?:^|:)\Q@{[_unescape(shift)]}\E$/}
-
-sub _pc {
- my ($class, $args, $current) = @_;
-
- # ":checked"
- return exists $current->[2]{checked} || exists $current->[2]{selected}
- if $class eq 'checked';
-
- # ":not"
- return !_match($args, $current, $current) if $class eq 'not';
-
- # ":empty"
- return !grep { !_empty($_) } @$current[4 .. $#$current] if $class eq 'empty';
-
- # ":root"
- return $current->[3] && $current->[3][0] eq 'root' if $class eq 'root';
-
- # ":nth-child", ":nth-last-child", ":nth-of-type" or ":nth-last-of-type"
- if (ref $args) {
- my $type = $class =~ /of-type$/ ? $current->[1] : undef;
- my @siblings = @{_siblings($current, $type)};
- @siblings = reverse @siblings if $class =~ /^nth-last/;
-
- for my $i (0 .. $#siblings) {
- next if (my $result = $args->[0] * $i + $args->[1]) < 1;
- last unless my $sibling = $siblings[$result - 1];
- return 1 if $sibling eq $current;
- }
- }
-
- # ":only-child" or ":only-of-type"
- elsif ($class eq 'only-child' || $class eq 'only-of-type') {
- my $type = $class eq 'only-of-type' ? $current->[1] : undef;
- $_ ne $current and return undef for @{_siblings($current, $type)};
- return 1;
- }
-
- return undef;
-}
-
-sub _select {
- my ($one, $tree, $group) = @_;
-
- my @results;
- my @queue = @$tree[($tree->[0] eq 'root' ? 1 : 4) .. $#$tree];
- while (my $current = shift @queue) {
- next unless $current->[0] eq 'tag';
-
- unshift @queue, @$current[4 .. $#$current];
- next unless _match($group, $current, $tree);
- $one ? return $current : push @results, $current;
- }
-
- return $one ? undef : \@results;
-}
-
-sub _selector {
- my ($selector, $current) = @_;
-
- for my $s (@$selector) {
- my $type = $s->[0];
-
- # Tag
- if ($type eq 'tag') { return undef unless $current->[1] =~ $s->[1] }
-
- # Attribute
- elsif ($type eq 'attr') { return undef unless _attr(@$s[1, 2], $current) }
-
- # Pseudo-class
- elsif ($type eq 'pc') { return undef unless _pc(@$s[1, 2], $current) }
- }
-
- return 1;
-}
-
-sub _sibling {
- my ($selectors, $current, $tree, $immediate, $pos) = @_;
-
- my $found;
- for my $sibling (@{_siblings($current)}) {
- return $found if $sibling eq $current;
-
- # "+" (immediately preceding sibling)
- if ($immediate) { $found = _combinator($selectors, $sibling, $tree, $pos) }
-
- # "~" (preceding sibling)
- else { return 1 if _combinator($selectors, $sibling, $tree, $pos) }
- }
-
- return undef;
-}
-
-sub _siblings {
- my ($current, $type) = @_;
-
- my $parent = $current->[3];
- my @siblings = grep { $_->[0] eq 'tag' }
- @$parent[($parent->[0] eq 'root' ? 1 : 4) .. $#$parent];
- @siblings = grep { $type eq $_->[1] } @siblings if defined $type;
-
- return \@siblings;
-}
-
-sub _unescape {
- my $value = shift;
-
- # Remove escaped newlines
- $value =~ s/\\\n//g;
-
- # Unescape Unicode characters
- $value =~ s/\\([0-9a-fA-F]{1,6})\s?/pack 'U', hex $1/ge;
-
- # Remove backslash
- $value =~ s/\\//g;
-
- return $value;
-}
-
-sub _value {
- my ($op, $value, $insensitive) = @_;
- return undef unless defined $value;
- $value = ($insensitive ? '(?i)' : '') . quotemeta _unescape($value);
-
- # "~=" (word)
- return qr/(?:^|\s+)$value(?:\s+|$)/ if $op eq '~';
-
- # "*=" (contains)
- return qr/$value/ if $op eq '*';
-
- # "^=" (begins with)
- return qr/^$value/ if $op eq '^';
-
- # "$=" (ends with)
- return qr/$value$/ if $op eq '$';
-
- # Everything else
- return qr/^$value$/;
-}
-
-1;
-
-=for Pod::Coverage *EVERYTHING*
-
-=cut
+++ /dev/null
-package DOM::Tiny::_Collection;
-
-use strict;
-use warnings;
-use Carp 'croak';
-use List::Util;
-use Scalar::Util 'blessed';
-
-use constant REDUCE => ($] >= 5.008009 ? \&List::Util::reduce : \&_reduce);
-
-our $VERSION = '0.004';
-
-sub new {
- my $class = shift;
- return bless [@_], ref $class || $class;
-}
-
-sub TO_JSON { [@{shift()}] }
-
-sub compact {
- my $self = shift;
- return $self->new(grep { defined && (ref || length) } @$self);
-}
-
-sub each {
- my ($self, $cb) = @_;
- return @$self unless $cb;
- my $i = 1;
- $_->$cb($i++) for @$self;
- return $self;
-}
-
-sub first {
- my ($self, $cb) = (shift, shift);
- return $self->[0] unless $cb;
- return List::Util::first { $_ =~ $cb } @$self if ref $cb eq 'Regexp';
- return List::Util::first { $_->$cb(@_) } @$self;
-}
-
-sub flatten { $_[0]->new(_flatten(@{$_[0]})) }
-
-sub grep {
- my ($self, $cb) = (shift, shift);
- return $self->new(grep { $_ =~ $cb } @$self) if ref $cb eq 'Regexp';
- return $self->new(grep { $_->$cb(@_) } @$self);
-}
-
-sub join {
- join +(defined($_[1]) ? $_[1] : ''), map {"$_"} @{$_[0]};
-}
-
-sub last { shift->[-1] }
-
-sub map {
- my ($self, $cb) = (shift, shift);
- return $self->new(map { $_->$cb(@_) } @$self);
-}
-
-sub reduce {
- my $self = shift;
- @_ = (@_, @$self);
- goto &{REDUCE()};
-}
-
-sub reverse { $_[0]->new(reverse @{$_[0]}) }
-
-sub shuffle { $_[0]->new(List::Util::shuffle @{$_[0]}) }
-
-sub size { scalar @{$_[0]} }
-
-sub slice {
- my $self = shift;
- return $self->new(@$self[@_]);
-}
-
-sub sort {
- my ($self, $cb) = @_;
-
- return $self->new(sort @$self) unless $cb;
-
- my $caller = caller;
- no strict 'refs';
- my @sorted = sort {
- local (*{"${caller}::a"}, *{"${caller}::b"}) = (\$a, \$b);
- $a->$cb($b);
- } @$self;
- return $self->new(@sorted);
-}
-
-sub tap {
- my ($self, $cb) = (shift, shift);
- $_->$cb(@_) for $self;
- return $self;
-}
-
-sub to_array { [@{shift()}] }
-
-sub uniq {
- my ($self, $cb) = (shift, shift);
- my %seen;
- return $self->new(grep { !$seen{$_->$cb(@_)}++ } @$self) if $cb;
- return $self->new(grep { !$seen{$_}++ } @$self);
-}
-
-sub _flatten {
- map { _ref($_) ? _flatten(@$_) : $_ } @_;
-}
-
-# For perl < 5.8.9
-sub _reduce (&@) {
- my $code = shift;
-
- return shift unless @_ > 1;
-
- my $caller = caller;
-
- no strict 'refs';
-
- local (*{"${caller}::a"}, *{"${caller}::b"}) = (\my $x, \my $y);
-
- $x = shift;
- foreach my $e (@_) {
- $y = $e;
- $x = $code->();
- }
-
- $x;
-}
-
-sub _ref { ref $_[0] eq 'ARRAY' || blessed $_[0] && $_[0]->isa(__PACKAGE__) }
-
-1;
-
-=for Pod::Coverage *EVERYTHING*
-
-=cut
+++ /dev/null
-package DOM::Tiny::_HTML;
-
-use strict;
-use warnings;
-use DOM::Tiny::Entities qw(html_escape html_unescape);
-use Scalar::Util 'weaken';
-
-our $VERSION = '0.004';
-
-my $ATTR_RE = qr/
- ([^<>=\s\/]+|\/) # Key
- (?:
- \s*=\s*
- (?s:(?:"(.*?)")|(?:'(.*?)')|([^>\s]*)) # Value
- )?
- \s*
-/x;
-my $TOKEN_RE = qr/
- ([^<]+)? # Text
- (?:
- <(?:
- !(?:
- DOCTYPE(
- \s+\w+ # Doctype
- (?:(?:\s+\w+)?(?:\s+(?:"[^"]*"|'[^']*'))+)? # External ID
- (?:\s+\[.+?\])? # Int Subset
- \s*)
- |
- --(.*?)--\s* # Comment
- |
- \[CDATA\[(.*?)\]\] # CDATA
- )
- |
- \?(.*?)\? # Processing Instruction
- |
- \s*([^<>\s]+\s*(?>(?:$ATTR_RE){0,32766})*) # Tag
- # Workaround for perl's limit of * to {0,32767}
- )>
- |
- (<) # Runaway "<"
- )??
-/xis;
-
-# HTML elements that only contain raw text
-my %RAW = map { $_ => 1 } qw(script style);
-
-# HTML elements that only contain raw text and entities
-my %RCDATA = map { $_ => 1 } qw(title textarea);
-
-# HTML elements with optional end tags
-my %END = (body => 'head', optgroup => 'optgroup', option => 'option');
-
-# HTML elements that break paragraphs
-$END{$_} = 'p' for
- 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 with optional end tags and scoping rules
-my %CLOSE
- = (li => [{li => 1}, {ul => 1, ol => 1}], tr => [{tr => 1}, {table => 1}]);
-$CLOSE{$_} = [\%TABLE, {table => 1}] for qw(colgroup tbody tfoot thead);
-$CLOSE{$_} = [{dd => 1, dt => 1}, {dl => 1}] for qw(dd dt);
-$CLOSE{$_} = [{rp => 1, rt => 1}, {ruby => 1}] for qw(rp rt);
-$CLOSE{$_} = [{th => 1, td => 1}, {table => 1}] for qw(td th);
-
-# HTML elements without end tags
-my %EMPTY = 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 picture progress q ruby s samp),
- qw(script select small span strong sub sup svg template textarea time u),
- qw(var video wbr)
-);
-my @OBSOLETE = qw(acronym applet basefont big font strike tt);
-my %PHRASING = map { $_ => 1 } @OBSOLETE, @PHRASING;
-
-# HTML elements that don't get their self-closing flag acknowledged
-my %BLOCK = map { $_ => 1 } (
- qw(a address applet article aside b big blockquote body button caption),
- qw(center code col colgroup dd details dialog dir div dl dt em fieldset),
- qw(figcaption figure font footer form frameset h1 h2 h3 h4 h5 h6 head),
- qw(header hgroup html i iframe li listing main marquee menu nav nobr),
- qw(noembed noframes noscript object ol optgroup option p plaintext pre rp),
- qw(rt s script section select small strike strong style summary table),
- qw(tbody td template textarea tfoot th thead title tr tt u ul xmp)
-);
-
-sub new {
- my $class = shift;
- bless @_ ? @_ > 1 ? {@_} : {%{$_[0]}} : {}, ref $class || $class;
-}
-
-sub tree {
- my $self = shift;
- return exists $self->{tree} ? $self->{tree} : ($self->{tree} = ['root']) unless @_;
- $self->{tree} = shift;
- return $self;
-}
-
-sub xml {
- my $self = shift;
- return $self->{xml} unless @_;
- $self->{xml} = shift;
- return $self;
-}
-
-sub parse {
- my ($self, $html) = (shift, "$_[0]");
-
- my $xml = $self->xml;
- my $current = my $tree = ['root'];
- while ($html =~ /\G$TOKEN_RE/gcso) {
- my ($text, $doctype, $comment, $cdata, $pi, $tag, $runaway)
- = ($1, $2, $3, $4, $5, $6, $11);
-
- # Text (and runaway "<")
- $text .= '<' if defined $runaway;
- _node($current, 'text', html_unescape $text) if defined $text;
-
- # Tag
- if (defined $tag) {
-
- # End
- if ($tag =~ /^\/\s*(\S+)/) { _end($xml ? $1 : lc $1, $xml, \$current) }
-
- # Start
- elsif ($tag =~ m!^([^\s/]+)([\s\S]*)!) {
- my ($start, $attr) = ($xml ? $1 : lc $1, $2);
-
- # Attributes
- my (%attrs, $closing);
- while ($attr =~ /$ATTR_RE/go) {
- my $key = $xml ? $1 : lc $1;
- my $value = defined($2) ? $2 : defined($3) ? $3 : $4;
-
- # Empty tag
- ++$closing and next if $key eq '/';
-
- $attrs{$key} = defined $value ? html_unescape $value : $value;
- }
-
- # "image" is an alias for "img"
- $start = 'img' if !$xml && $start eq 'image';
- _start($start, \%attrs, $xml, \$current);
-
- # Element without end tag (self-closing)
- _end($start, $xml, \$current)
- if !$xml && $EMPTY{$start} || ($xml || !$BLOCK{$start}) && $closing;
-
- # Raw text elements
- next if $xml || !$RAW{$start} && !$RCDATA{$start};
- next unless $html =~ m!\G(.*?)<\s*/\s*\Q$start\E\s*>!gcsi;
- _node($current, 'raw', $RCDATA{$start} ? html_unescape $1 : $1);
- _end($start, 0, \$current);
- }
- }
-
- # DOCTYPE
- elsif (defined $doctype) { _node($current, 'doctype', $doctype) }
-
- # Comment
- elsif (defined $comment) { _node($current, 'comment', $comment) }
-
- # CDATA
- elsif (defined $cdata) { _node($current, 'cdata', $cdata) }
-
- # Processing instruction (try to detect XML)
- elsif (defined $pi) {
- $self->xml($xml = 1) if !exists $self->{xml} && $pi =~ /xml/i;
- _node($current, 'pi', $pi);
- }
- }
-
- return $self->tree($tree);
-}
-
-sub render { _render($_[0]->tree, $_[0]->xml) }
-
-sub _end {
- my ($end, $xml, $current) = @_;
-
- # Search stack for start tag
- my $next = $$current;
- do {
-
- # Ignore useless end tag
- return if $next->[0] eq 'root';
-
- # Right tag
- return $$current = $next->[3] if $next->[1] eq $end;
-
- # Phrasing content can only cross phrasing content
- return if !$xml && $PHRASING{$end} && !$PHRASING{$next->[1]};
-
- } while $next = $next->[3];
-}
-
-sub _node {
- my ($current, $type, $content) = @_;
- push @$current, my $new = [$type, $content, $current];
- weaken $new->[2];
-}
-
-sub _render {
- my ($tree, $xml) = @_;
-
- # Text (escaped)
- my $type = $tree->[0];
- return html_escape($tree->[1]) if $type eq 'text';
-
- # Raw text
- return $tree->[1] if $type eq 'raw';
-
- # DOCTYPE
- return '<!DOCTYPE' . $tree->[1] . '>' if $type eq 'doctype';
-
- # Comment
- return '<!--' . $tree->[1] . '-->' if $type eq 'comment';
-
- # CDATA
- return '<![CDATA[' . $tree->[1] . ']]>' if $type eq 'cdata';
-
- # Processing instruction
- return '<?' . $tree->[1] . '?>' if $type eq 'pi';
-
- # Root
- return join '', map { _render($_, $xml) } @$tree[1 .. $#$tree]
- if $type eq 'root';
-
- # Start tag
- my $tag = $tree->[1];
- my $result = "<$tag";
-
- # Attributes
- for my $key (sort keys %{$tree->[2]}) {
- my $value = $tree->[2]{$key};
- $result .= $xml ? qq{ $key="$key"} : " $key" and next unless defined $value;
- $result .= qq{ $key="} . html_escape($value) . '"';
- }
-
- # No children
- return $xml ? "$result />" : $EMPTY{$tag} ? "$result>" : "$result></$tag>"
- unless $tree->[4];
-
- # Children
- no warnings 'recursion';
- $result .= '>' . join '', map { _render($_, $xml) } @$tree[4 .. $#$tree];
-
- # End tag
- return "$result</$tag>";
-}
-
-sub _start {
- my ($start, $attrs, $xml, $current) = @_;
-
- # Autoclose optional HTML elements
- if (!$xml && $$current->[0] ne 'root') {
- if (my $end = $END{$start}) { _end($end, 0, $current) }
-
- elsif (my $close = $CLOSE{$start}) {
- my ($allowed, $scope) = @$close;
-
- # Close allowed parent elements in scope
- my $parent = $$current;
- while ($parent->[0] ne 'root' && !$scope->{$parent->[1]}) {
- _end($parent->[1], 0, $current) if $allowed->{$parent->[1]};
- $parent = $parent->[3];
- }
- }
- }
-
- # New tag
- push @$$current, my $new = ['tag', $start, $attrs, $$current];
- weaken $new->[3];
- $$current = $new;
-}
-
-1;
-
-=for Pod::Coverage *EVERYTHING*
-
-=cut
+++ /dev/null
-use strict;
-use warnings;
-use Test::More;
-use DOM::Tiny::_Collection;
-use JSON::PP ();
-
-sub c { DOM::Tiny::_Collection->new(@_) }
-
-# Array
-is c(1, 2, 3)->[1], 2, 'right result';
-is_deeply [@{c(3, 2, 1)}], [3, 2, 1], 'right result';
-my $collection = c(1, 2);
-push @$collection, 3, 4, 5;
-is_deeply [@$collection], [1, 2, 3, 4, 5], 'right result';
-
-# Tap into method chain
-is_deeply c(1, 2, 3)->tap(sub { $_->[1] += 2 })->to_array, [1, 4, 3],
- 'right result';
-
-# compact
-is_deeply c(undef, 0, 1, '', 2, 3)->compact->to_array, [0, 1, 2, 3],
- 'right result';
-is_deeply c(3, 2, 1)->compact->to_array, [3, 2, 1], 'right result';
-is_deeply c()->compact->to_array, [], 'right result';
-
-# flatten
-is_deeply c(1, 2, [3, 4], 5, c(6, 7))->flatten->to_array,
- [1, 2, 3, 4, 5, 6, 7], 'right result';
-is_deeply c(undef, 1, [2, {}, [3, c(4, 5)]], undef, 6)->flatten->to_array,
- [undef, 1, 2, {}, 3, 4, 5, undef, 6], 'right result';
-
-# each
-$collection = c(3, 2, 1);
-is_deeply [$collection->each], [3, 2, 1], 'right elements';
-$collection = c([3], [2], [1]);
-my @results;
-$collection->each(sub { push @results, $_->[0] });
-is_deeply \@results, [3, 2, 1], 'right elements';
-@results = ();
-$collection->each(sub { push @results, shift->[0], shift });
-is_deeply \@results, [3, 1, 2, 2, 1, 3], 'right elements';
-
-# first
-$collection = c(5, 4, [3, 2], 1);
-is $collection->first, 5, 'right result';
-is_deeply $collection->first(sub { ref $_ eq 'ARRAY' }), [3, 2], 'right result';
-is $collection->first(sub { shift() < 5 }), 4, 'right result';
-is $collection->first(qr/[1-4]/), 4, 'right result';
-is $collection->first(sub { ref $_ eq 'CODE' }), undef, 'no result';
-$collection = c(c(1, 2, 3), c(4, 5, 6), c(7, 8, 9));
-is_deeply $collection->first(first => sub { $_ == 5 })->to_array, [4, 5, 6],
- 'right result';
-$collection = c();
-is $collection->first, undef, 'no result';
-is $collection->first(sub {defined}), undef, 'no result';
-
-# last
-is c(5, 4, 3)->last, 3, 'right result';
-is c(5, 4, 3)->reverse->last, 5, 'right result';
-is c()->last, undef, 'no result';
-
-# grep
-$collection = c(1, 2, 3, 4, 5, 6, 7, 8, 9);
-is_deeply $collection->grep(qr/[6-9]/)->to_array, [6, 7, 8, 9],
- 'right elements';
-is_deeply $collection->grep(sub {/[6-9]/})->to_array, [6, 7, 8, 9],
- 'right elements';
-is_deeply $collection->grep(sub { $_ > 5 })->to_array, [6, 7, 8, 9],
- 'right elements';
-is_deeply $collection->grep(sub { $_ < 5 })->to_array, [1, 2, 3, 4],
- 'right elements';
-is_deeply $collection->grep(sub { shift == 5 })->to_array, [5],
- 'right elements';
-is_deeply $collection->grep(sub { $_ < 1 })->to_array, [], 'no elements';
-is_deeply $collection->grep(sub { $_ > 9 })->to_array, [], 'no elements';
-$collection = c(c(1, 2, 3), c(4, 5, 6), c(7, 8, 9));
-is_deeply $collection->grep(first => sub { $_ >= 5 })->flatten->to_array,
- [4, 5, 6, 7, 8, 9], 'right result';
-
-# join
-$collection = c(1, 2, 3);
-is $collection->join, '123', 'right result';
-is $collection->join(''), '123', 'right result';
-is $collection->join('---'), '1---2---3', 'right result';
-is $collection->join("\n"), "1\n2\n3", 'right result';
-#is $collection->join('/')->url_escape, '1%2F2%2F3', 'right result'; # no bytestream object
-
-# map
-$collection = c(1, 2, 3);
-is $collection->map(sub { $_ + 1 })->join(''), '234', 'right result';
-is_deeply [@$collection], [1, 2, 3], 'right elements';
-is $collection->map(sub { shift() + 2 })->join(''), '345', 'right result';
-is_deeply [@$collection], [1, 2, 3], 'right elements';
-$collection = c(c(1, 2, 3), c(4, 5, 6), c(7, 8, 9));
-is $collection->map('reverse')->map(join => "\n")->join("\n"),
- "3\n2\n1\n6\n5\n4\n9\n8\n7", 'right result';
-is $collection->map(join => '-')->join("\n"), "1-2-3\n4-5-6\n7-8-9",
- 'right result';
-
-# reverse
-$collection = c(3, 2, 1);
-is_deeply $collection->reverse->to_array, [1, 2, 3], 'right order';
-$collection = c(3);
-is_deeply $collection->reverse->to_array, [3], 'right order';
-$collection = c();
-is_deeply $collection->reverse->to_array, [], 'no elements';
-
-# shuffle
-$collection = c(0 .. 10000);
-my $random = $collection->shuffle;
-is $collection->size, $random->size, 'same number of elements';
-isnt "@$collection", "@$random", 'different order';
-is_deeply c()->shuffle->to_array, [], 'no elements';
-
-# size
-$collection = c();
-is $collection->size, 0, 'right size';
-$collection = c(undef);
-is $collection->size, 1, 'right size';
-$collection = c(23);
-is $collection->size, 1, 'right size';
-$collection = c([2, 3]);
-is $collection->size, 1, 'right size';
-$collection = c(5, 4, 3, 2, 1);
-is $collection->size, 5, 'right size';
-
-# reduce
-$collection = c(2, 5, 4, 1);
-is $collection->reduce(sub { $a + $b }), 12, 'right result';
-is $collection->reduce(sub { $a + $b }, 5), 17, 'right result';
-is c()->reduce(sub { $a + $b }), undef, 'no result';
-
-# sort
-$collection = c(2, 5, 4, 1);
-is_deeply $collection->sort->to_array, [1, 2, 4, 5], 'right order';
-is_deeply $collection->sort(sub { $b cmp $a })->to_array, [5, 4, 2, 1],
- 'right order';
-is_deeply $collection->sort(sub { $_[1] cmp $_[0] })->to_array, [5, 4, 2, 1],
- 'right order';
-$collection = c(qw(Test perl DOM));
-is_deeply $collection->sort(sub { uc(shift) cmp uc(shift) })->to_array,
- [qw(DOM perl Test)], 'right order';
-$collection = c();
-is_deeply $collection->sort->to_array, [], 'no elements';
-is_deeply $collection->sort(sub { $a cmp $b })->to_array, [], 'no elements';
-
-# slice
-$collection = c(1, 2, 3, 4, 5, 6, 7, 10, 9, 8);
-is_deeply $collection->slice(0)->to_array, [1], 'right result';
-is_deeply $collection->slice(1)->to_array, [2], 'right result';
-is_deeply $collection->slice(2)->to_array, [3], 'right result';
-is_deeply $collection->slice(-1)->to_array, [8], 'right result';
-is_deeply $collection->slice(-3, -5)->to_array, [10, 6], 'right result';
-is_deeply $collection->slice(1, 2, 3)->to_array, [2, 3, 4], 'right result';
-is_deeply $collection->slice(6, 1, 4)->to_array, [7, 2, 5], 'right result';
-is_deeply $collection->slice(6 .. 9)->to_array, [7, 10, 9, 8], 'right result';
-
-# uniq
-$collection = c(1, 2, 3, 2, 3, 4, 5, 4);
-is_deeply $collection->uniq->to_array, [1, 2, 3, 4, 5], 'right result';
-is_deeply $collection->uniq->reverse->uniq->to_array, [5, 4, 3, 2, 1],
- 'right result';
-$collection = c([1, 2, 3], [3, 2, 1], [3, 1, 2]);
-is_deeply $collection->uniq(sub { $_->[1] }), [[1, 2, 3], [3, 1, 2]],
- 'right result';
-$collection = c(c(1, 2), c(1, 2), c(2, 1));
-is_deeply $collection->uniq(join => ',')->flatten->to_array, [1, 2, 2, 1],
- 'right result';
-
-# TO_JSON
-is +JSON::PP->new->convert_blessed->encode(c(1, 2, 3)), '[1,2,3]', 'right result';
-
-done_testing();
projects / catagits/DOM-Tiny.git / commitdiff