#!/usr/bin/perl
use strict;
use warnings;

my %oberkonfig = (
	cron_errorlog	=> 'cron_error.txt',
);

print "Rueckgabe: '".fritz_reconnect(\%oberkonfig)."'\n";
# Rückgaben:
# ==========
# ''					-> jetzt keine Ausführung, da die aktuelle Stunde nicht $job_konfig{ausfuehrung_um} entspricht
#						   oder die aktuelle IP von heute ist (es wird nur ein Reconnect pro Tag ausgeführt)
# String				-> Fehler aufgetreten, im String steht eine sprechende Fehlermeldung
# String mit Präfix |	-> Auftrag ausgeführt, der String enthält alte und neue Verbindungsdaten
#
# hier im Beispiel soll der Reconnect immer erst durchgeführt werden,
# wenn die aktuelle Stunde auf der Uhr $job_konfig{ausfuehrung_um} entspricht,
# es wird von einem Aufruf per Cronjob in jeder vollen Stunde des Tages ausgegangen

# --------------------------------------------------------------------------------------------------------------
sub systemlog_eintrag {
	# Möglichkeit, in einer Art Protokoll die Verbindungsdaten aufzuzeichnen
	return;
}
# --------------------------------------------------------------------------------------------------------------
sub error {
	print STDERR '['.localtime().'] [error] [MELDUNG JOB '.$_[1].'] '.$_[0]."\n";
}
# --------------------------------------------------------------------------------------------------------------
sub fritz_reconnect {
	#
	# DSL Reconnect der FRITZ!Box per Screenscraping mit Perl nebst WWW::Mechanize und Digest::MD5
	#
	# Getestet mit der FRITZ!Box 7490
	# mit FRITZ!OS 06.30
	# Firmware-Version: 113.06.30
	# im Oktober 2015
	#
	my %job_konfig = (
		ausfuehrung_um			=> 4,																			# Stunde des Tages, wann der Reconnect durchgeführt werden soll
		url						=> 'http://fritz.box',
		pass					=> '***',
#		debug					=> 'test_%s.html',																# Dateiname und ggf. Pfad für die Dateien in die die einzelnen Seiten gespeichert werden, %s ist die laufende Nummer, z.B. '/meinpfad/debug_%2.html', nicht definieren, wenn kein Debug erwünscht
		response_reconnect		=> 'done:0',																	# was die FRITZ!Box auf "Neu verbinden" zurück liefert
		wait_nach_reconnect		=> 20,																			# max. Sekunden Wartezeit nach dem Reconnect zum Abruf der neuen Verbindungsdaten
		verbindungsstatus		=> sub {																		# hier den Regex für den Verbindungsstatus pflegen; stattdessen im HTML Baum mit HTML::TreeBuilder rum zu suchen bietet sich hier nicht an
			my ($content,$data) = @_;
			# für FRITZ!OS 6.30:
			if ($$content =~ m~<td><div id='ipv4_title'>Internet, IPv4</div></td><td id='ipv4_led'><div class='led_green'>&nbsp;</div></td><td><div id='ipv4_info'><span class="limited">verbunden seit (\d+).(\d+).(\d+), (\d+):(\d+) Uhr</span>, <span class="limited" style="max-width:240px;">([^<]+)</span><span class="limited">,<br>IP-Adresse: (\d+).(\d+).(\d+).(\d+)</span></div></td>~) {
				$data->{datum} = "$1.$2.$3";
				$data->{zeit} = "$4:$5";
				$data->{provider} = $6;
				$data->{ip4} = "$7.$8.$9.$10";
				$data->{found} = defined;
			}
		},

		# ----- ab hier nichts mehr ändern -----
		fritzbox_hex_md5		=> sub {
			# Dank an Jan! https://www.perl-community.de/bat/poard/thread/19845#ms_182588
			my ($string) = @_;
			my @chars = split(//,$$string);
			require Digest::MD5;
			return Digest::MD5::md5_hex(join("\0",@chars)."\0");
		},
		makeDots				=> sub {
			my ($str) = @_;
			my $newStr = '';
			my $len = length($str);
			for (my $i = 0; $i < $len; $i ++) {
				my $char = substr($str,$i,1);
				$newStr .= (ord($char) > 255 ? '.' : $char);
			}
			return $newStr;
		},
		write_debug_file		=> sub {
			my ($k,$mech,$nr) = @_;
			if (defined $k->{debug}) {
				$$nr ++;
				$$mech->save_content(
					sprintf($k->{debug},$$nr),
					binmode				=> ':raw',
					decoded_by_headers	=> 1,
				);
			}
		},
	);

	my ($env) = @_;
	my ($back,$content,$g_challenge);
	my @jetzt = localtime(time());
	return '' if $jetzt[2] != $job_konfig{ausfuehrung_um};

	require WWW::Mechanize;
	my $mech = WWW::Mechanize->new(
		agent		=> 'Automat',																				# ist der FRITZ!Box egal
		quiet		=> 1,																						# prophylaktisch
		onwarn		=> \&{																						# sollte definiert werden sonst schreibt es bei einer Warnung trotz quiet=>1 auf STDERR
			sub {
				$back = "Warnung '".join('',@_)."'";
				goto FEHLER_UND_RUECKSPRUNG_ZUM_HAUPTPROGRAMM;
			}
		},
		onerror		=> \&{																						# sollte definiert werden sonst schreibt es bei einem Fehler trotz quiet=>1 auf STDERR
			sub {
				$back = "Fehler '".join('',@_)."'";
				goto FEHLER_UND_RUECKSPRUNG_ZUM_HAUPTPROGRAMM;
			}
		},
		stack_depth	=> 0,																						# die history Tabelle wird nicht gebraucht, Speicher schonen
	);

	my $debug_nr = 0;
	do {{																										# sonst werden die Einrückungen im Code zu breit
		my $dest_url = "$job_konfig{url}/login.lua";

		# Login Formular aufrufen
		$mech->get($dest_url);
		$content = $mech->content();
		if (!defined $content || $content eq '') { $back = "Abruf der Ressource '$dest_url' gescheitert"; last; }

		$job_konfig{write_debug_file}->(\%job_konfig,\$mech,\$debug_nr);
		if ($content =~ /g_challenge( ?)=( ?)"([^"]{8})"/) { $g_challenge = $3; }
		else { $back = "Finde die Variablendefinition zu &gt;g_challenge&lt; nicht"; last; }

		my $form_id = 'uiMainForm';
		my $formular = $mech->form_id($form_id);																# selektiert auch das default Formular obwohl es in der Doku anders steht
		if (!defined $formular) { $back = "Finde das Formular mit der ID '$form_id' nicht"; last; }

		my $temp = $g_challenge.'-'.$job_konfig{makeDots}->($job_konfig{pass});
		my $var_response = $g_challenge.'-'.$job_konfig{fritzbox_hex_md5}->(\$temp);
		my $feldname = 'response';
		$mech->field($feldname,$var_response,1);																# field() liefert leider kein def/undef zurück

		# Login Formular absenden
		if (!$mech->submit()) { $back = "Das Formular mit der ID '$form_id' konnte nicht abgesendet werden"; last; }

		$content = $mech->content();
		if (!defined $content || $content eq '') { $back = "Nach Absenden des Formulars mit der ID '$form_id' wird nichts mehr geliefert"; last; }

		$job_konfig{write_debug_file}->(\%job_konfig,\$mech,\$debug_nr);
		my $link_zu_dsl;
		if ($content =~ /\/internet\/inetstat_monitor\.lua\?sid\=([0-9a-z]+)/) {								# nutze kein $mech->follow_link(), weil der Link unten nochmal gebraucht wird
			$link_zu_dsl = "$job_konfig{url}/internet/inetstat_monitor.lua?sid=$1";
		}
		else { $back = "Finde den Menüpunkt 'Internet' nicht"; last; }

		# Menüpunkt 'Internet' anklicken
		$mech->get($link_zu_dsl);
		$content = $mech->content();
		if (!defined $content || $content eq '') { $back = "FRITZ!Box liefert im Menüpunkt 'Internet' nichts zurück"; last; }

		$job_konfig{write_debug_file}->(\%job_konfig,\$mech,\$debug_nr);
		my %data;
		$job_konfig{verbindungsstatus}->(\$content,\%{$data{alt}});
		if (!defined $data{alt}{found}) { $back = "Im Menüpunkt 'Online-Monitor' konnte der Verbindungsstatus für 'Internet, IPv4' nicht gefunden werden"; last; }

		if ($data{alt}{datum} eq sprintf('%02d.%02d.%04d',$jetzt[3],$jetzt[4]+1,$jetzt[5]+1900)) { return ''; }

		if ($content =~ /internet\/inetstat_monitor\.lua\?sid=([0-9a-z]+)&useajax=1&action=disconnect/) {
			$dest_url = "$job_konfig{url}/internet/inetstat_monitor.lua?sid=$1&useajax=1&action=disconnect";
		}
		else { $back = "Im Menüpunkt 'Online-Monitor' konnte der Schalter 'Neu verbinden' nicht gefunden werden"; last; }

		# Schalter 'Neu verbinden anklicken'
		my $time_reconnect = time();
		$mech->get($link_zu_dsl.'&useajax=1&action=disconnect');
		$content = $mech->content();
		if (!defined $content || $content eq '') { $back = "Die FRTIZ!Box liefert auf 'Neu verbinden' nichts zurück"; last; }

		$job_konfig{write_debug_file}->(\%job_konfig,\$mech,\$debug_nr);
		if ($content ne $job_konfig{response_reconnect}) { $back = "Der Aufruf 'Neu verbinden' liefert nach disconnect nicht '$job_konfig{response_reconnect}' zurück sondern '$content'"; last; }

		# wieder Menüpunkt 'Internet' aufrufen
		my $start = time();
		while(																									# als Schleife, weil das Connect unterschiedlich lange dauert
			(
				!exists $data{neu}
					||
				"$data{alt}{datum}$data{alt}{zeit}" eq "$data{neu}{datum}$data{neu}{zeit}"
			)
				&&
			time() - $start < $job_konfig{wait_nach_reconnect}
		) {
			sleep(2);
			$mech->get($link_zu_dsl);
			$content = $mech->content();
			if (!defined $content || $content eq '') { $back = "FRITZ!Box liefert im Menüpunkt 'Internet' beim zweiten Aufruf nichts zurück"; last; }

			$job_konfig{write_debug_file}->(\%job_konfig,\$mech,\$debug_nr);
			delete $data{neu} if exists $data{neu};
			$job_konfig{verbindungsstatus}->(\$content,\%{$data{neu}});
			if (!defined $data{neu}{found}) { $back = "Nach dem Reconnect konnte im Menüpunkt 'Online-Monitor' der Verbindungsstatus für 'Internet, IPv4' nicht gefunden werden"; last; }
		}
		last if defined $back;

		if ("$data{alt}{datum}$data{alt}{zeit}" eq "$data{neu}{datum}$data{neu}{zeit}") {
			my @t = localtime($time_reconnect);
			$back = "Etwas muss schief gelaufen sein, trotz Reconnect am "
				.sprintf("%02d.%02d.%04d um %02d:%02d Uhr",@t[3..5],$t[2],$t[1])
				." und einer Wartezeit von "
				.(time() - $start)
				." Sekunde(n) werden keine neuen Verbindungsdaten ausgegeben, nur die alte IP Adresse $data{alt}{ip4} von $data{alt}{datum} um $data{alt}{zeit} Uhr konnte ermittelt werden"
			;
			last;
		}

		my $msg = "|Job erledigt, bisherige IP Adresse seit $data{alt}{datum} um $data{alt}{zeit} Uhr lautete"
			." $data{alt}{ip4}, neue IP Adresse seit $data{neu}{datum} um $data{neu}{zeit} Uhr lautet"
			." $data{neu}{ip4}"
		;
		main::systemlog_eintrag(0,1,20,$msg);
		return $msg;

	}} while(0);

	FEHLER_UND_RUECKSPRUNG_ZUM_HAUPTPROGRAMM:
	error($back,87);
	return "Fehler aufgetreten siehe '$env->{cron_errorlog}'";
}