From: Matt S Trout Date: Sat, 9 Apr 2016 16:48:30 +0000 (+0000) Subject: burninate _Module.pm stuff and collection test X-Git-Tag: v0.004~5 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits%2FDOM-Tiny.git;a=commitdiff_plain;h=ee225ce0c4db754c34f30b1b181e0abe0c550fc1 burninate _Module.pm stuff and collection test --- diff --git a/lib/DOM/Tiny/_CSS.pm b/lib/DOM/Tiny/_CSS.pm deleted file mode 100644 index 0612ce1..0000000 --- a/lib/DOM/Tiny/_CSS.pm +++ /dev/null @@ -1,322 +0,0 @@ -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 diff --git a/lib/DOM/Tiny/_Collection.pm b/lib/DOM/Tiny/_Collection.pm deleted file mode 100644 index 547946c..0000000 --- a/lib/DOM/Tiny/_Collection.pm +++ /dev/null @@ -1,136 +0,0 @@ -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 diff --git a/lib/DOM/Tiny/_HTML.pm b/lib/DOM/Tiny/_HTML.pm deleted file mode 100644 index 04a5344..0000000 --- a/lib/DOM/Tiny/_HTML.pm +++ /dev/null @@ -1,291 +0,0 @@ -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 '[1] . '>' if $type eq 'doctype'; - - # Comment - return '' if $type eq 'comment'; - - # CDATA - return '[1] . ']]>' if $type eq 'cdata'; - - # Processing instruction - return '[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>" - unless $tree->[4]; - - # Children - no warnings 'recursion'; - $result .= '>' . join '', map { _render($_, $xml) } @$tree[4 .. $#$tree]; - - # End tag - return "$result"; -} - -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 diff --git a/t/collection.t b/t/collection.t deleted file mode 100644 index b455ba1..0000000 --- a/t/collection.t +++ /dev/null @@ -1,173 +0,0 @@ -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();