WWW::Mechanize::Plugin::DOM::Window - Window object for the DOM plugin

  (
      alert => VOID|METHOD,
      confirm => BOOL|METHOD,
      ...
  )

package WWW::Mechanize::Plugin::DOM::Window;

use strict; use warnings; no warnings qw 'utf8 parenthesis';

our $VERSION = '0.014';

use Hash::Util::FieldHash::Compat 'fieldhash';
use HTML::DOM::Interface 0.019 ':all';
use HTML::DOM::NodeList::Magic;
use HTML::DOM::View 0.018;
use Scalar::Util 'weaken';
use Time::HiRes 'time';

our @ISA = qw[ HTML::DOM::View
               HTML::DOM::EventTarget ];

no constant 1.03 ();
use constant::lexical +{ do {
	my $x; map +($_=>$x++), qw[
		lert cnfm prmp loco meck topp frms prnt
	]  # we use ‘meck’ so as not to conflict with the method
}};

use overload fallback=>1, (qw/@{} %{}/, ('_frames_collection')x2)[0,3,1,2];

fieldhash my %timeouts; # keyed by document
fieldhash my %navi;     # keyed by mech

# This does not follow the same format as %HTML::DOM::Interface; this cor-
# responds to the format of hashes *within* %H:D:I. The other format does
# not apply here, since we can’t bind the class like other classes. This
# needs to be bound to the global  object  (at  least  in  JavaScript).
our %Interface = (
	%{$HTML::DOM::Interface{AbstractView}},
	%{$HTML::DOM::Interface{EventTarget}},
	alert => VOID|METHOD,
	confirm => BOOL|METHOD,
	prompt => STR|METHOD,
	location => OBJ,
	setTimeout => NUM|METHOD,
	clearTimeout => NUM|METHOD,
	open => OBJ|METHOD,
	window => OBJ|READONLY,
	self => OBJ|READONLY,
	navigator => OBJ|READONLY,
	top => OBJ|READONLY,
	frames => OBJ|READONLY,
	length => NUM|READONLY,
	parent => OBJ|READONLY,
);

sub new {
	my $self = bless\[], shift;
	weaken($$self->[meck] = my $mech = shift);
	$$self->[loco] = ('WWW::Mechanize::Plugin::DOM::Location')->new(
				$mech
			);
	$self;
}

sub alert {
	my $self = shift;
	&{$$self->[lert]||sub{print @_,"\n";()}}(@_);
}
sub confirm {
	my $self = shift;
	($$self->[cnfm]||$$self->[meck]->die(
		"There is no default confirm function"
	 ))->(@_)
}
sub prompt {
	my $self = shift;
	($$self->[prmp]||$$self->[meck]->die(
		"There is no default prompt function"
	 ))->(@_)
}

sub set_alert_function   { $${$_[0]}[lert]     = $_[1]; }
sub set_confirm_function { $${$_[0]}[cnfm] = $_[1]; }
sub set_prompt_function  { $${$_[0]}[prmp] = $_[1]; }

sub location {
	my $self = shift;
	$$self->[loco]->href(@_) if @_;
	$$self->[loco];
}

sub navigator {
	my $mech = ${+shift}->[meck];
	$navi{$mech} ||=
		new WWW::Mechanize::Plugin::DOM::Navigator:: $mech;
}

sub setTimeout {
	my $doc = shift->document;
	my $time = time;
	my ($code, $ms) = @_;
	$ms /= 1000;
	my $t_o = $timeouts{$doc}||=[];
	$$t_o[my $id = @$t_o] =
		[$ms+$time, $code];
	return $id;
}

sub clearTimeout {
	delete $timeouts{shift->document}[shift];
	return;
}

sub open {
	${+shift}->[meck]->get(shift);
			# ~~~ Just a placeholder for now.
	return;
}

# ~~~ This really doesn’t belong here, but in DOM.pm. But it needs to
# access the same info as the timeout methods above. Maybe those should
# delegate to DOM.pm methods.
sub _check_timeouts {
	my $time = time;
	my $self = shift;
	local *_;
	my $t_o = $timeouts{$self->document}||return;
	for my $id(0..$#$t_o) {
		next unless $_ = $$t_o[$id];
		$$_[0] <= $time and
			($$self->[meck]->plugin('JavaScript')||return)
				->eval($$_[1]),
			delete $$t_o[$id];
	}
	return
}

# ~~~ This may be moved to Plugin::DOM proper later.
sub _count_timers {
 	my $self =  shift;
	my $t_o = $timeouts{$self->document}||return 0;
	my $count;
	for my $id(0..$#$t_o) {
		next unless $_ = $$t_o[$id];
		++$count
	}
	$count;
}

sub window { $_[0] }
*self = *frames = *window;
sub length { $_[0]->_frames_collection->length }

sub top {
	my $self = shift;
	$$self->[topp] || do {
		my $parent = $self;
		while() {
			$$parent->[prnt] or
			 weaken( $$self->[topp] = $parent), last;
			$parent = $$parent->[prnt];
		}
		$$self->[topp]
	};
}

sub parent {
	my $self = shift;
	$$self->[prnt] || $self;
}

sub _set_parent { weaken( ${$_[0]}->[prnt] = $_[1] ) }

sub event_listeners_enabled {
	${+shift}->[meck]->plugin("DOM")->scripts_enabled
}

sub _frames_collection {
	my $self = shift;
	$$self->[frms] ||= do{
		my $doc = $self->document;
		WWW::Mechanize::Plugin::DOM::Frames->new(
		HTML::DOM::NodeList::Magic->new(
		    sub { $doc->look_down(_tag => qr/^i?frame\z/) },
		    $doc
		))
	}
}

# ~~~ Will we need this?
#sub _reset_frames_collection { delete ${+shift}->[frms] }

sub document {
	my $self = shift;
	@_ || return $self->SUPER::document;
	delete $$self->[frms];
	$self->SUPER::document(@_);
}

sub mech { $${+shift}[meck] }


package WWW::Mechanize::Plugin::DOM::Location;

use URI;
use HTML::DOM::Interface qw'STR METHOD VOID';
use Scalar::Util 'weaken';

our $VERSION = '0.014';

use overload fallback => 1, '""' => sub{${+shift}->uri};

$$_{~~__PACKAGE__} = 'Location',
$$_{Location} = {
	hash => STR,
	host => STR,
	hostname => STR,
	href => STR,
	pathname => STR,
	port => STR,
	protocol => STR,
	search => STR,
	reload => VOID|METHOD,
	replace => VOID|METHOD,
}
for \%WWW::Mechanize::Plugin::DOM::Interface;

sub new { # usage: new .....::Location $uri, $mech
	my $class = shift;
	weaken (my $mech = shift);
	my $self = bless \$mech, $class;
	$self;
}

sub hash {
	my $loc = shift;
	my $old = (my $uri = $$loc->uri)->fragment;
	$old = "#$old" if defined $old;
	if (@_){
		shift() =~ /#?(.*)/s;
		(my $uri_copy = $uri->clone)->fragment($1);
		$uri_copy->eq($uri) or $$loc->get($uri);
	}
	$old||''
}

sub host {
	my $loc = shift;
	if (@_) {
		(my $uri = $$loc->uri->clone)->host(shift);
		$$loc->get($uri);
	}
	else {
		$$loc->uri->host;
	}
}

sub hostname {
	my $loc = shift;
	if (@_) {
		(my $uri = $$loc->uri->clone)->host_port(shift);
		$$loc->get($uri);
	}
	else {
		$$loc->uri->host_port;
	}
}

sub href {
	my $loc = shift;
	if (@_) {
		$$loc->get(shift);
	}
	else {
		$$loc->uri->as_string;
	}
}

sub pathname {
	my $loc = shift;
	if (@_) {
		(my $uri = $$loc->uri->clone)->path(shift);
		$$loc->get($uri);
	}
	else {
		$$loc->uri->path;
	}
}

sub port {
	my $loc = shift;
	if (@_) {
		(my $uri = $$loc->uri->clone)->port(shift);
		$$loc->get($uri);
	}
	else {
		$$loc->uri->port;
	}
}

sub protocol {
	my $loc = shift;
	if (@_) {
		shift() =~ /(.*):?/s;
		(my $uri = $$loc->uri->clone)->scheme($1);
		$$loc->get($uri);
	}
	else {
		$$loc->uri->scheme . ':';
	}
}

sub search {
	my $loc = shift;
	if (@_){
		shift() =~ /(\??)(.*)/s;
		(my $uri_copy = (my $uri = $$loc->uri)->clone)->query(
			$1&&length$2 ? $2 : undef
		);
		$uri_copy->eq($uri) or $$loc->get($uri);
	} else {
		my $q = $$loc->uri->query;
		defined $q ? "?$q" : "";
	}
}


# ~~~ Safari doesn't support forceGet. Do I need to?
sub reload  { # args (forceGet) 
	${+shift}->reload
}
sub replace { # args (URL)
	my $mech = ${+shift};
	$mech->back();
	$mech->get(shift);
}


package WWW::Mechanize::Plugin::DOM::Navigator;

use HTML::DOM::Interface qw'STR READONLY';
use Scalar::Util 'weaken';

our $VERSION = '0.014';

$$_{~~__PACKAGE__} = 'Navigator',
$$_{Navigator} = {
	appName => STR|READONLY,
	appVersion => STR|READONLY,
	userAgent => STR|READONLY,
}
for \%WWW::Mechanize::Plugin::DOM::Interface;

no constant 1.03 ();
use constant::lexical {
	mech => 0,
	name => 1,
	vers => 2,
};

sub new {
	weaken((my $self = bless[],pop)->[mech] = pop);
	$self;
}

sub appName {
	my $self = shift;
	my $old = $self->[name];
	defined $old or $old = ref $self->[mech];
	@_ and $self->[name] = shift;
	return $old;
}

sub appVersion {
	my $self = shift;
	my $old = $self->[vers];
	if(!defined $old) {
		$old = $self->userAgent;
		$old =~ /(\d.*)/s
		? $old = $1
		: $old = ref($self->[mech])->VERSION;
	}
	@_ and $self->[vers] = shift;
	return $old;
}

sub userAgent {
	shift->[mech]->agent;
}


# ~~~ This is horribly inefficient and clunky. It probably needs to be
#     programmed in full here, or at least the ‘Collection’ part (a tiny
#     bit of copy&paste).
package WWW::Mechanize::Plugin::DOM::Frames;

our $VERSION = '0.014';

use HTML::DOM::Collection;
our @ISA = "HTML::DOM::Collection";

use overload fallback => 1,'@{}' => sub {
	[map $_->contentWindow, @{shift->${\'SUPER::(@{}'}}]
};

sub FETCH { (shift->SUPER::FETCH(@_)||return)->contentWindow }



# ------------------ DOCS --------------------#

1;