#!/usr/bin/perl -w

# VERSION 0.2 (Second released beta)

# Ressources for Perl beginners (like me)
#  - Perl reference site (i don't understand why, it's ugly) : http://www.cpan.org/
#  - Perl bases : http://en.wikibooks.org/wiki/Programming:Perl
#  - GTK-Perl tutorial (french) : http://perso.wanadoo.fr/gtk2-perl/Gtk2perl_tutoriel.html

# Uses
use strict ;
use Gtk2 '-init' ;

# Boolean values
use constant True => 1 ;
use constant False => 0 ;

# DONE -d device  device to use
# DONE -p      dump current settings
# DONE -f x    set framerate (0...63)
# DONE -b      store settings in nonvolatile RAM
# DONE -r      restore settings from nonvolatile RAM
# DONE -x      restore factory settings
# DONE -c x    set compression preference (0-3)
# DONE -g x    set automatic gain control (0...65535)
# TODO -s x    set shutter speed (1...65535)
# DONE -w auto/manual/indoor/outdoor/fl
# DONE        set automatic white balance mode
# TODO -a x    red-balance (only if -w manual) (0...65535)
# TODO -e x    blue-balance (idem) (0...65535)
# TODO -i x    speed of automatic white balance (1...65535)
# TODO -j x    delay for automatic white balance (1...65535)
# TODO -k x    set led on-time (0...25500ms
# TODO -l x    set led off-time
# DONE -m x    set electronic sharpness (0...65535)
# DONE -n x    set backlight compensation (0=0ff, other=on)
# DONE -o x    set antiflicker mode (0=0ff, other=on)
# DONE -q x    set noise reduction mode (0=none...3=high)
# TODO -t x    reset pan(bit 0) and/or tilt(bit 1)
# TODO -u      query pan/tilt status
# TODO -y x    set pan position
# TODO -z x    set tilt position

# Global TODO : 
#  - device management
#  - discover what is 'brightness' in the dump (no set command)
#  - shutter speed <= can we get it ?
#  - default value in white balance menu
#  - details of manual and automatic white balance
#  - led on/off-time
#  - pan management
#  - subroutine to interface dump parsing and values setting
#    (shall i re-dump and re-set values after a change ? seems to be needed for some, but heavy :/)
#  - more and more and more controls : 
#   - is setpwc in path (installed), executable ?
#   - does the user CAN setpwc the device ?
#  - best subroutines & variables names, Object-oriented perl ?
#  - best comments (sorry for my english)
#  - info & debug activated by switch on CLI
#  => 1/2 should be DONE if u send me a motorized and well driver-managed (led) webcam :]

# =========================================================== [ VARIABLES ] ===
# Debug variables
	my $debug = True ;	# Display message when unexpected thing arrive
	my $info = True ;	# Display message when expected thing arrive
# Misc
	my $intercept_events = False ;	# On window creation, event are created for
					# each widgets, so we allow events to be
					# intercepted only after window creation
# Window Settings
	# Pointers
	my $table ;
	# Misc
	my $border_width = 5 ;
	my $allow_shrink = False ;
	my $allow_grow = False ;
	my $auto_shrink = True ;
	my $position = 'center' ; #mouse, center, none
	# Table
	my $line = 0 ;
	my $homogeneous = False ; # table columns have same width and height
	my $xoptions = ['fill','expand'] ;
	my $yoptions = ['fill','expand'] ;
	my $xpadding = 0 ;
	my $ypadding = 0 ;
	# Adjustement
	my $step_increment = 1 ; # increment on left button
	my $page_increment = 1000 ; # increment on right button
	my $page_size = False ;
	# Spin
	my $climb_rate = 0.1 ; # Increment acceleration
	my $wrap = False ; # if spin is max and is highed, set it to min
	my $update_policy = 'delayed' ; # (continuous,discontinuous,delayed)
# Setpwc variables
	my $setpwc_device = '/dev/video0' ;
	my $setpwc_current_device = 'No device detected' ;
	my $setpwc_resolution_x = 0 ;
	my $setpwc_resolution_y = 0 ;
	my $setpwc_resolution = 0 ;
	my $setpwc_offset_x = 0 ;
	my $setpwc_offset_y = 0 ;
	my $setpwc_offset = 0 ;
	my $setpwc_framerate = 0 ;
	my $setpwc_brightness = 0 ;
	my $setpwc_hue = 0 ;
	my $setpwc_colour = 0 ;
	my $setpwc_contrast = 0 ;
	my $setpwc_whiteness = 0 ;
	my $setpwc_palette = 'none' ;
	my $setpwc_compression = 0 ;
	my $setpwc_gain = 0 ;
	my $setpwc_whitebalance = 'none' ;
	my $setpwc_whitebalance_red = 0 ;
	my $setpwc_whitebalance_blue = 0 ;
	my $setpwc_sharpness = 0 ;
	my $setpwc_backlight = False ;
	my $setpwc_antiflicker = False ;
	my $setpwc_noise = 0 ;

# ============================================================= [ PROGRAM ] ===
	parse_setpwc() ;
	create_window() ;
	$intercept_events = True ;
	# GTK Main loop
	info(' === Main loop : begin === ') ;
	Gtk2->main ;
	info(' === Main loop : end === ') ;

# ========================================================= [ SUBROUTINES ] ===
# --------------------------------------------------------------- [ Window ]---
# Window creation
sub create_window {
	info(' === Creating window === ') ;
	my $window = Gtk2::Window->new ;
		# Title
		$window->set_title ('PWC based Webcam Configuration') ;
		# Misc
		$window->set_border_width($border_width) ;
		#$window->set_policy($allow_shrink,$allow_grow,$auto_shrink) ;
		$window->set_position($position) ;
		# Connect
		$window->signal_connect('delete_event',\&on_delete) ;
		$window->signal_connect('destroy',\&on_destroy) ;
	# Table
	$table = Gtk2::Table->new(17,3,$homogeneous) ;
		$window->add($table) ; 
		$table->show() ;
	# Table lines
		# Information lines
	my $entry_device_name = add_line_e('Device name',$setpwc_current_device) ;
	my $entry_resolution = add_line_e('Resolution',$setpwc_resolution) ;
	my $entry_offset = add_line_e('Offset',$setpwc_offset) ;
	my $entry_palette = add_line_e('Palette',$setpwc_palette) ;
	my $entry_brightness = add_line_e('Brightness',$setpwc_brightness) ;
	my $entry_device = add_line_e('Device',$setpwc_device,True) ;
	add_line_h() ;
		# Set lines
	my $entry_framerate = add_line_s('Framerate',$setpwc_framerate,0,63,'f') ;
	my $entry_hue = add_line_e('Hue',$setpwc_hue) ;
	my $entry_colour = add_line_e('Colour',$setpwc_colour) ;
	my $entry_contrast = add_line_e('Contrast',$setpwc_contrast) ;
	my $entry_whiteness = add_line_e('Whiteness',$setpwc_whiteness) ;
	my $entry_compression = add_line_s('Compression',$setpwc_compression,0,3,'c') ;
	my $entry_gain = add_line_l('Gain',$setpwc_gain,0,65535,'g') ;
	my $entry_whitebalance =  add_line_m('White balance') ;
	my $entry_whitebalance_red = add_line_e('Red balance',$setpwc_whitebalance_red) ;
	my $entry_whitebalance_blue = add_line_e('Red balance',$setpwc_whitebalance_blue) ;
	my $entry_sharpness = add_line_l('Sharpness',$setpwc_sharpness,0,65535,'m') ;
	my $entry_backlight = add_line_c('Backlight',$setpwc_backlight,'n') ;
	my $entry_antiflicker = add_line_c('Anti-flicker',$setpwc_antiflicker,'o') ;
	my $entry_noise = add_line_s('Noise reduction',$setpwc_noise,0,3,'q') ;
		# buttons
	my $button_store = Gtk2::Button->new_with_mnemonic('_Store settings') ;
		Gtk2::Tooltips->new->set_tip ($button_store,'store settings in nonvolatile RAM','') ;
		$button_store->signal_connect('clicked',\&intercept_button,'b') ;
		$button_store->show() ;
		$table->attach($button_store,0,1,$line,$line+1,$xoptions,$yoptions,$xpadding,$ypadding) ;
	my $button_restore = Gtk2::Button->new_with_mnemonic('_Restore settings') ;
		Gtk2::Tooltips->new->set_tip ($button_restore,'restore settings from nonvolatile RAM','') ;
		$button_restore->signal_connect('clicked',\&intercept_button,'p') ;
		$button_restore->show() ;
		$table->attach($button_restore,1,2,$line,$line+1,$xoptions,$yoptions,$xpadding,$ypadding) ;
	my $button_factory = Gtk2::Button->new_with_mnemonic('_Factory defaults') ;
		Gtk2::Tooltips->new->set_tip ($button_factory,'restore factory settings','') ;
		$button_factory->signal_connect('clicked',\&intercept_button,'x') ;
		$button_factory->show() ;
		$table->attach($button_factory,2,3,$line,$line+1,$xoptions,$yoptions,$xpadding,$ypadding) ;
	$line++ ;
	# Disp window
	$window->show() ;
}
# --------------------------------------------------------------- [ Widgets ]---
sub add_line_h {
	# Adds a separator, no params, return separator's pointer
	my $separator = Gtk2::HSeparator->new() ;
	$separator->show() ;
	$table->attach($separator,0,3,$line,$line+1,$xoptions,$yoptions,$xpadding,$ypadding) ;
	info('line '.$line.' : separator added to table') ;
	$line++ ;
	return $separator ;
}
sub add_line_e {
	# Add a line in the table containing a label and an editable
	# 1st param : label text, 2nd param = default value
	# Returns the editable's pointer
	my $label = shift ;
	my $edit_text = shift ;
	my $editable = shift ;
	my $line_label = Gtk2::Label->new($label) ;
		$line_label->show() ;
		$table->attach($line_label,0,1,$line,$line+1,$xoptions,$yoptions,$xpadding,$ypadding) ;
	my $line_entry = Gtk2::Entry->new() ;
		Gtk2::Tooltips->new->set_tip ($line_entry,$label,''); 
		$line_entry->set_editable($editable) ;
		$line_entry->set_text($edit_text) ;
		$line_entry->show() ;
		$table->attach($line_entry,1,3,$line,$line+1,$xoptions,$yoptions,$xpadding,$ypadding) ;
	info('line '.$line.' : entry added to table : ['.$label.'],['.$edit_text.']') ;
	if ($editable) {
#'changed'
#'insert-text'
#'delete-text'
#'activate'
#'set-editable'
#'move-cursor'
#'move-word'
#'move-page'
#'move-to-row'
#'move-to-column'
#'kill-char'
#'kill-word' 
#'kill-line'
#'cut-clipboard'
#'copy-clipboard'
#'paste-clipboard'
		$line_entry->signal_connect('changed',\&intercept_entry,$line_entry) ;
		info('line '.$line.' : callback declared for entry ['.$label.']') ;
	}
	$line++ ;
	return $line_entry ;
}
sub add_line_c {
	# Add a line in the table containing a label and an checkbox
	# 1st param : label text, 2nd param = default checked
	# Returns the check's pointer
	my $label = shift ;
	my $state = shift ;
	my $command = shift ;
	my $line_label = Gtk2::Label->new($label) ;
		$line_label->show() ;
		$table->attach($line_label,0,1,$line,$line+1,$xoptions,$yoptions,$xpadding,$ypadding) ;
	my $line_check = Gtk2::CheckButton->new() ;
		$line_check->signal_connect('toggled',\&intercept_checkbox,$command) ;
		Gtk2::Tooltips->new->set_tip ($line_check,$label,''); 
		$line_check->set_active($state);
		$line_check->show() ;
		$table->attach($line_check,1,3,$line,$line+1,$xoptions,$yoptions,$xpadding,$ypadding) ;
	info('line '.$line.' Check added to table : ['.$label.'],['.$state.']') ;
	$line++ ;
	return $line_check ;
}
sub add_line_s {
	# Add a line in the table containing a label and a spinbutton
	# params : 1st : label text, 2nd : default value, 3rd : min, 4th : max
	# Returns the adjustment's pointer
	my $label = shift ;
	my $value = shift ;
	my $min = shift ;
	my $max = shift ;
	my $command = shift ;
	my $line_label = Gtk2::Label->new($label) ;
		$line_label->show() ;
		$table->attach($line_label,0,1,$line,$line+1,$xoptions,$yoptions,$xpadding,$ypadding) ;
	my $line_adjustment = Gtk2::Adjustment->new($value,$min,$max,$step_increment,
							$page_increment,$page_size) ;
		$line_adjustment->signal_connect('value_changed',\&intercept_adjustment,$command) ;
	my $line_spin = Gtk2::SpinButton->new($line_adjustment,$climb_rate,0);
		Gtk2::Tooltips->new->set_tip ($line_spin,$label,$label);
		$line_spin->set_numeric(True);
		$line_spin->set_wrap($wrap);
		$line_spin->set_snap_to_ticks(True);
		$line_spin->set_update_policy('if_valid');
		$line_spin->show() ;
		$table->attach($line_spin,1,3,$line,$line+1,$xoptions,$yoptions,$xpadding,$ypadding) ;
	info('line '.$line.' : spin added to table : ['.$label.'],['.$value.']') ;
	$line++ ;
	return $line_spin ;
}
sub add_line_l {
	# Add a line in the table containing a label and a scale
	# params : 1st : label text, 2nd : default value, 3rd : min, 4th : max
	# Returns the adjustment's pointer
	my $label = shift ;
	my $value = shift ;
	my $min = shift ;
	my $max = shift ;
	my $command = shift ;
	my $line_label = Gtk2::Label->new($label) ;
		$line_label->show() ;
		$table->attach($line_label,0,1,$line,$line+1,$xoptions,$yoptions,$xpadding,$ypadding) ;
	my $line_adjustment = Gtk2::Adjustment->new($value,$min,$max,$step_increment,
							$page_increment,$page_size) ;
		$line_adjustment->signal_connect('value_changed',\&intercept_adjustment,$command) ;
	my $line_range = Gtk2::HScale->new($line_adjustment);
		Gtk2::Tooltips->new->set_tip ($line_range,$label,'');
		$line_range->set_update_policy($update_policy) ;
		$line_range->show() ;
		$table->attach($line_range,1,3,$line,$line+1,$xoptions,$yoptions,$xpadding,$ypadding) ;
	info('line '.$line.' : spin added to table : ['.$label.'],['.$value.']') ;
	$line++ ;
	return $line_range ;
}
sub add_line_m {
	# Add a line in the table containing a label and a menu
	# params : 1st : label text
	# Returns the menu's pointer
	my $label = shift ;
	my $line_label = Gtk2::Label->new($label) ;
		$line_label->show() ;
		$table->attach($line_label,0,1,$line,$line+1,$xoptions,$yoptions,
				$xpadding,$ypadding) ;
	my $line_option = Gtk2::OptionMenu->new() ;
	Gtk2::Tooltips->new->set_tip ($line_option,$label,'') ;
		my $menu = Gtk2::Menu->new() ;
		$menu->append(make_menu_item('auto',\&intercept_menu,'auto')) ;
		$menu->append(make_menu_item('manual',\&intercept_menu,'manual')) ;
		$menu->append(make_menu_item('indoor',\&intercept_menu,'indoor')) ;
		$menu->append(make_menu_item('outdoor',\&intercept_menu,'outdoor')) ;
		$menu->append(make_menu_item('fl',\&intercept_menu,'fl')) ;
		$line_option->set_menu($menu) ;
		$line_option->show() ;
		$table->attach($line_option,1,3,$line,$line+1,$xoptions,$yoptions,
				$xpadding,$ypadding) ;
		$line++ ;
	return $line_option
}
sub  make_menu_item {
	# Subdivision of add_line_m, create one item of the menu
	# params : 1st : display name, 2nd : callback, 3rd : callback param
	# Returns the menu item's pointer
	my ( $name, $callback, $data ) = @_ ;
	my $item ;
	$item = Gtk2::MenuItem->new($name) ;
	$item->signal_connect('activate',$callback, $data ) ;
	$item->show() ;
	return $item ;
} 
# ---------------------------------------------------[ Signal interceptors ] ---
# Window events
sub on_delete {
	info('Normal exit : delete') ;
	Gtk2->main_quit ;
	return True ;
}
sub on_destroy {
	debug('Anormal exit : destroy') ;
	Gtk2->main_quit ;
	return False ;
}
# Widgets events by type
sub intercept_button {
	# Intercept buton pression and launch associated command
	if ( $intercept_events) {
		my $widget = shift ;
		exec_cmd('-'.shift) ;
	}
}
sub intercept_checkbox {
	# Intercept checkbox stats toggle and launch associated command with checkbox's state
	if ( $intercept_events) {
		my $active = 0 ;
		if ( shift->get_active ) {
			$active = 1 ;
		}
		exec_cmd('-'.shift().' '.$active) ;
	}
}
sub intercept_menu {
	# Intercept menu selection and launch whitebalance command with menu's value
	if ( $intercept_events) {
		my $widget = shift ;
		exec_cmd('-w '.shift) ;
	}
}
sub intercept_adjustment {
	# Intercept adjustment value change and launch associated command with adjustment's value
	if ( $intercept_events) {
		my $value = int(shift->value) ;
		exec_cmd('-'.shift().' '.$value) ;
	}
}
sub intercept_entry {
	my  ( $widget, $entry ) = @_ ;
	my $entry_text = $entry->get_text() ;
	if ( -r $entry_text ) { 
		$setpwc_device = $entry_text ;
		info('Device changed to '.$setpwc_device) ;
		# TODO : Use style to change color instead of frame, complex, and nearly unusefull
		#my $style = $entry->get_property('style') ;
		$entry->set_property('has-frame',True) ;
	} else {
		$entry->set_property('has-frame',False) ;
	}
}
# ----------------------------------------------------------- [ Execution ] ---
sub exec_cmd {
	# execute setpwc with command in param
	my $cmd = 'setpwc -d '.$setpwc_device.' '.shift().' 2> /dev/null &' ; # stderr redirected
				# because setpwc version is printed to it
				# command launched in the background because
				# of a ''bug'' in GTK spin-buttons
	#my $result = `$cmd` ; # Other way to do, not really tested
	info('Executing '.$cmd) ;
	if (system($cmd) == 0 ) {
		return True ;
	} else {
		debug('Error executing shell command: '.$cmd.' -- '.$!) ;
		return False ;
	} 
}
# --------------------------------------------------------------[ Display ] ---
sub debug {
	# Displays debug message (something wrong happend) if debug is active
	my $debug_text = shift ;
	chomp($debug_text) ;
	if ( $debug ) {
		print '    DEBUG	'.$debug_text."\n" ;
	}
}
sub info {
	# Display info message (something right happend) if info is active
	my $info_text = shift ;
	chomp($info_text) ;
	if ( $info ) {
		print '  INFO	'.$info_text."\n" ;
	}
}
sub onoff2bool {
	my $onoff = shift ;
	my $return = False ;
	if ( $onoff eq 'on' ) {
		$return = True ;
	} elsif ( $onoff eq 'off' ) {
		$return = False ;
	} else {
		debug('on/off value equals nor on nor off, possible parsing bug, or setpwc problem !') ;
	}
	return $return ;
}
# ------------------------------------------------------- [ setpwc parser ] ---
sub parse_setpwc {
	# Dump settings and parse result to fill $setpwc_* variables
	my $cmd = 'setpwc -p 2> /dev/null' ;
	info(' === Parsing `'.$cmd."` === ") ;
	open(DUMP,$cmd.'|') ;
	while (<DUMP>) {
		if ( /^Current device: (.*)$/ ){
			$setpwc_current_device = $1 ;
			info('Device detected : '.$setpwc_current_device) ;
		} elsif ( /^VIDIOCPWCPROBE returns: (.*)$/ ) {
			info('Vidioc PWC Probe detected : '.$1) ;
		} elsif ( /^Resolution \(x, y\): (.*), (.*)$/ ) {
			$setpwc_resolution_x = $1 ;
			$setpwc_resolution_y = $2 ;
			$setpwc_resolution = $1.'x'.$2 ;
			info('Resolution detected : '.$setpwc_resolution) ;
		} elsif ( /^Offset: (\d*), (\d*)$/ ) {
			$setpwc_offset_x = $1 ;
			$setpwc_offset_y = $2 ;
			$setpwc_offset = $1.','.$2 ;
			info('Offset detected : '.$setpwc_offset) ;
		} elsif ( /^Framerate: (\d*)$/ ) {
			$setpwc_framerate = $1 ;
			info('Framerate detected : '.$setpwc_framerate) ;
		} elsif ( /^Brightness: (\d*)$/ ) {
			$setpwc_brightness = $1 ;
			info('Brightness detected : '.$setpwc_brightness) ;
		} elsif ( /^Hue: (\d*)$/ ) {
			$setpwc_hue = $1 ;
			info('Hue detected : '.$setpwc_hue) ;
		} elsif ( /^Colour: (\d*)$/ ) {
			$setpwc_colour = $1 ;
			info('Colour detected : '.$setpwc_colour) ;
		} elsif ( /^Contrast: (\d*)$/ ) {
			$setpwc_contrast = $1 ;
			info('Contrast detected : '.$setpwc_contrast) ;
		} elsif ( /^Whiteness: (\d*)$/ ) {
			$setpwc_whiteness = $1 ;
			info('Whiteness detected : '.$setpwc_whiteness) ;
		} elsif ( /^Palette: (.*)$/ ) {
			$setpwc_palette = $1 ;
			info('Palette detected : '.$setpwc_palette) ;
		} elsif ( /^Compression preference: (\d*)$/ ) {
			$setpwc_compression = $1 ;
			info('Compression detected : '.$setpwc_compression) ;
		} elsif ( /^Automatic gain control: (.*)$/ ) {
			$setpwc_gain = $1 ;
			info('Gain detected : '.$setpwc_gain) ;
		} elsif ( /^Whitebalance mode: (\S*)(.*)?$/ ) {
			$setpwc_whitebalance = $1 ;
			info('Whitebalance detected : '.$setpwc_whitebalance) ;
			if ( $2 eq '' ) {
				info('No whitebalance info') ;
			} elsif ( $2 =~ /^\s(\(red: (\d*), blue: (\d*)\))$/ ) {
				info('Whitebalance info : '.$1) ;
				$setpwc_whitebalance_red = $2 ;
				$setpwc_whitebalance_blue = $3 ;
				info('Whitebalance red : '.$setpwc_whitebalance_red.
					', blue : '.$setpwc_whitebalance_blue) ;
			} else {
				debug('Whitebalance untreated info : ['.$2.']') ;
			}
		} elsif ( /^Sharpness: (.*)$/ ) {
			$setpwc_sharpness = $1 ;
			info('Sharpness detected : '.$setpwc_sharpness) ;
		} elsif ( /^Backlight compensation mode: (on|off)$/ ) {
			$setpwc_backlight = onoff2bool($1) ;
			info('Backlight detected : '.$setpwc_backlight) ;
		} elsif ( /^Anti-flicker mode: (on|off)$/ ) {
			$setpwc_antiflicker = onoff2bool($1) ;
			info('Anti-flicker detected : '.$setpwc_antiflicker) ;
		} elsif ( /^Noise reduction mode: (\d*) (.*)$/ ) {
			$setpwc_noise = $1 ;
			info('Noise detected : '.$setpwc_noise) ;
			info('Noise info : '.$2) ;
		# Unsupported functionalities
		} elsif ( /^(.*) is not supported by the combination$/ ) {
			info('Unsupported functionality : '.$1) ;
		# unusefull 2nd line
		} elsif ( /^of your webcam and the driver.$/) {
		} else {
			debug('Unparsed text : ['.$_.']') ;
		}
	}
}