From 0c0ab7302b2df33ec00850cb068b4de56ab92bf2 Mon Sep 17 00:00:00 2001 From: Shawn Laffan Date: Mon, 2 Nov 2020 15:12:55 +1100 Subject: [PATCH] Add Gtk3 version of BiodiverseGUI.pl This has no changes yet, but will simplify parallel debugging. Updates #770 --- bin/BiodiverseGUI_gtk3.pl | 297 ++++++++++++++++++++++++++++++++++ lib/Biodiverse/GUI/Grid.pm | 26 ++- lib/Biodiverse/GUI/Legend.pm | 11 +- t/test_spreadsheet_import.xls | Bin 40448 -> 40448 bytes 4 files changed, 317 insertions(+), 17 deletions(-) create mode 100644 bin/BiodiverseGUI_gtk3.pl diff --git a/bin/BiodiverseGUI_gtk3.pl b/bin/BiodiverseGUI_gtk3.pl new file mode 100644 index 000000000..e6b317379 --- /dev/null +++ b/bin/BiodiverseGUI_gtk3.pl @@ -0,0 +1,297 @@ +use strict; +use warnings; +use Carp; + +use 5.022; + +#use File::Basename; +use Cwd; +use FindBin qw ( $Bin ); +use Path::Class (); + +BEGIN { + # make sure menubars are visible when running under Ubuntu Unity + $ENV{UBUNTU_MENUPROXY} = undef; +#$ENV{GTK_DEBUG} = 'interactive'; +#$ENV{GTK_PATH} = 'C:\berrybrew\5.28.0_64_PDL\perl\site\share'; +#$ENV{GTK_THEME} = 'Emacs'; + # if running under PAR on a mac + if ($^O eq 'darwin' && $ENV{PAR_0}) { + say '++++'; + my $gdk_base = ("$ENV{PAR_TEMP}/inc/gdk-pixbuf-2.0/2.10.0"); + $ENV{GDK_PIXBUF_MODULEDIR} + = Path::Class::file ($gdk_base, 'loaders'); + say "Setting GDK_PIXBUF_MODULEDIR to $ENV{GDK_PIXBUF_MODULEDIR}"; + say "BUT IT DOES NOT EXIST" if !-d $ENV{GDK_PIXBUF_MODULEDIR}; + my $gdk_cache_file + = Path::Class::file ($gdk_base, 'loaders.cache'); + say "Setting GDK_PIXBUF_MODULE_FILE to $gdk_cache_file"; + $ENV{GDK_PIXBUF_MODULE_FILE} = $gdk_cache_file; + $ENV{PATH} = "$ENV{PAR_TEMP}/inc:" . $ENV{PATH}; + use File::Which; + my $loc = which ('gdk-pixbuf-query-loaders'); + say 'gdk-pixbuf-query-loaders is at ' . $loc; + say 'running gdk-pixbuf-query-loaders system calls'; + my $cache = `$loc`; + warn "system call to $loc failed: $?" + if $?; + system ('gdk-pixbuf-query-loaders', '--update-cache') == 0 + or warn "++++ could not update gdk-pixbuf-query-loaders cache: $?"; + say '++++'; + } +} + + + +#no warnings 'redefine'; +no warnings 'once'; +use English qw { -no_match_vars }; +our $VERSION = '3.1'; + +local $OUTPUT_AUTOFLUSH = 1; + + +# add the lib folder if needed +use rlib; + +say '@INC: ', join q{ }, @INC; + +# load up the user defined libs and settings +use Biodiverse::Config; +use Biodiverse::GUI::GUIManager; + +say "\n\nUsing Biodiverse engine version $Biodiverse::Config::VERSION"; + +# load Gtk +use Gtk3; +Gtk3::disable_setlocale; # leave LC_NUMERIC alone + +# my $icontheme = Gtk3::IconTheme->new; +# use List::Util qw /uniq/; +# say join "\n", 'Icon themes: ', uniq $icontheme->get_search_path; +# say join "\n", 'Gtk3 RC files: ', Gtk3::Rc->get_default_files; + +Gtk3->init; + +use Biodiverse::GUI::Callbacks; + +# Load filename specified in the arguments +my $numargs = scalar @ARGV; +my $filename; +my $caller_dir = cwd; # could cause drive problems + +if ( $numargs == 1 ) { + $filename = $ARGV[0]; + if ( $filename eq '--help' || $filename eq '-h' || $filename eq '/?' ) { + usage(); + exit; + } + elsif ( not( -e $filename and -r $filename ) ) { + warn " Error: Cannot read $filename\n"; + $filename = undef; + } +} +elsif ( $numargs > 1 ) { + usage(); +} + +## query the locale +#BEGIN { + #use POSIX qw /locale_h/; + #my $locale = setlocale(LC_ALL); + #say "\nCurrent perl numeric locale is: $locale"; + #my $locale_values = localeconv(); + #if ($locale_values->{decimal_point} eq ',') { + # say 'Locale uses a comma as the decimal separator'; + #} + my $num = sprintf "%.3f", 3.14; + if ($num =~ /,/) { + say 'Locale uses a comma as the decimal separator'; + } +#} + + +#my $eval_result; + +my $icon = get_iconfile(); +my $eval_result = eval { + Gtk3::Window::set_default_icon_from_file($icon) +}; +#croak $EVAL_ERROR if $EVAL_ERROR; + + +########################### +# Create the UI + +my $gui = Biodiverse::GUI::GUIManager->instance; + +my $ui_dir = get_ui_path(); +$gui->set_gtk_ui_path($ui_dir); + +my $builder = eval { get_main_window($gui); }; +croak $EVAL_ERROR if $EVAL_ERROR; + +my $user_data; +$builder->connect_signals($user_data, 'Biodiverse::GUI::Callbacks'); + +# Initialise the GUI Manager object +$gui->set_glade_xml($builder); + +$gui->init(); + +if ( defined $filename ) { + $filename = Path::Class::file($filename)->absolute->stringify; + $gui->open($filename); +} + +# hack for exe building under github actions +if (!($^O eq 'darwin' && $ENV{BDV_PP_BUILDING})) { + # Go! + Gtk3->main; +} + +# go back home (unless it has been deleted while we were away) +$eval_result = eval { chdir($caller_dir) }; +croak $EVAL_ERROR if $EVAL_ERROR; + +exit; + +################################################################################ + +sub get_main_window { + my $gui = shift; + my $dlgxml = Gtk3::Builder->new(); + $dlgxml->add_from_file($gui->get_gtk_ui_file('wndMain.ui')); + return $dlgxml; +} + +sub usage { + print STDERR << "END_OF_USAGE"; +Biodiverse - A spatial analysis tool for species (and other) diversity. + +usage: $0 + + filename: name of Biodiverse Project, BaseData, Tree or Matrix file to open\n + (bps, bds, bts or bms extension) +END_OF_USAGE + + exit(); +} + +sub get_ui_path { + my $ui_path; + + # get the one we're compiled with (if we're a PAR exe file) + if ($ENV{PAR_0}) { # we are running under PAR + $ui_path = Path::Class::file ($ENV{PAR_TEMP}, 'inc', 'ui'); + my $ui_path_str = $ui_path->stringify; + say "Using PAR ui path: $ui_path"; + return $ui_path_str; + } + + # get the ui path relative to $Bin + $ui_path = Path::Class::file( $Bin, 'ui' )->stringify; + if (! -e $ui_path) { + $ui_path = Path::Class::file( $Bin, 'bin', 'ui', )->stringify; + } + + die 'Cannot find glade the ui directory' if ! -d $ui_path; + + say "Using ui files in $ui_path"; + + return $ui_path; +} + + +sub get_iconfile { + + my $icon; + + if ($ENV{PAR_0}) { # we are running under PAR + $icon = Path::Class::file ($ENV{PAR_TEMP}, 'inc', 'Biodiverse_icon.ico'); + my $icon_str = $icon->stringify; + if (-e $icon_str) { + say "Using PAR icon file $icon"; + return $icon_str; + } + else { + # manually unpack the icon file + require Archive::Zip; + + my $folder = $icon->dir; + my $fname = $icon->basename; + my $zip = Archive::Zip->new($ENV{PAR_PROGNAME}) + or die "Unable to open $ENV{PAR_PROGNAME}"; + + my $success = $zip->extractMember ( $fname, $icon_str ); + + if (-e $icon) { + say "Using PAR icon file $icon"; + return $icon_str; + } + else { + say "Cannot locate $icon in the PAR archive"; + } + } + } + + $icon = Path::Class::file( $Bin, 'Biodiverse_icon.ico' )->stringify; + if (! -e $icon) { + $icon = Path::Class::file( $Bin, 'bin', 'Biodiverse_icon.ico' )->stringify; + } + if ( ! -e $icon) { + $icon = undef; + } + + return $icon; +} + + +# keep the console open if we have a failure +END { + if ($?) { + say "\n\n===== Program terminated abnormally. ====\n\n"; + say 'Press any key to continue.'; + ; + } + #else { + #$gui->destroy; # need to close the gui if we stay open always + #} +} + + +__END__ + +=head1 NAME + +BiodiverseGUI.pl + +=head1 DESCRIPTION + +A spatial analysis tool for researchers working on issues of species (and other) diversity + +This is the main script to run the GUI. + +See http://www.purl.org/biodiverse for more details. + +=head1 SYNOPSIS + + perl BiodiverseGUI.pl projectfile.bps + + perl BiodiverseGUI.pl basedatafile.bds + + perl BiodiverseGUI.pl treefile.bts + + perl BiodiverseGUI.pl matrixfile.bms + + +=head1 AUTHORS + +Shawn Laffan, Eugene Lubarsky, Dan Rosauer, Anthony Knittel, Michael Zhou, +Anderson Ku, Luke Fitzpatrick, Jason Mumbulla + +=head1 LICENSE + + LGPL + +=cut diff --git a/lib/Biodiverse/GUI/Grid.pm b/lib/Biodiverse/GUI/Grid.pm index ae2fa359b..e0aec5851 100644 --- a/lib/Biodiverse/GUI/Grid.pm +++ b/lib/Biodiverse/GUI/Grid.pm @@ -156,7 +156,7 @@ sub new { $self->{canvas}->get_hadjustment->signal_connect_swapped('value-changed', \&on_scroll, $self); # Set up canvas - $self->{canvas}->set_center_scroll_region(0); + #$self->{canvas}->set_center_scroll_region(0); $self->{canvas}->show; $self->set_zoom_fit_flag(1); $self->{dragging} = 0; @@ -166,20 +166,18 @@ sub new { } # Create background rectangle to receive mouse events for panning - my $rect = GooCanvas2::CanvasItem->new ( - $self->{canvas}->root, - 'GooCanvas2::CanvasRect', - x1 => 0, - y1 => 0, - x2 => CELL_SIZE_X, - fill_color_gdk => COLOUR_WHITE, - #outline_color => "black", - #width_pixels => 2, - y2 => CELL_SIZE_X, + # Might need to make a group here and add this to it + my $rect = GooCanvas2::CanvasRect->new ( + parent => $self->{canvas}->get_root_item, + x => 0, + y => 0, + width => CELL_SIZE_X, + height => CELL_SIZE_X, + 'fill-color' => 'white', ); - $rect->lower_to_bottom(); - - $self->{canvas}->root->signal_connect_swapped ( + #$rect->lower_to_bottom(); +##FIXME + $self->{canvas}->get_root_item->signal_connect_swapped ( event => \&on_background_event, $self, ); diff --git a/lib/Biodiverse/GUI/Legend.pm b/lib/Biodiverse/GUI/Legend.pm index 943cf2da7..92404c5f0 100644 --- a/lib/Biodiverse/GUI/Legend.pm +++ b/lib/Biodiverse/GUI/Legend.pm @@ -78,13 +78,18 @@ sub new { bless $self, $class; # Get the width and height of the canvas. #my ($width, $height) = $self->{canvas}->c2w($width_px || 0, $height_px || 0); - my ($width, $height) = $self->{canvas}->c2w($self->{width_px} || 0, $self->{height_px} || 0); + my ($width, $height) + = $self->{canvas}->convert_from_item_space( + $self->{canvas}->get_root_item, + $self->{width_px} || 0, + $self->{height_px} || 0, + ); +say "xxxxx $width, $height"; # Make group so we can pack the coloured # rectangles into it. $self->{legend_group} = GooCanvas2::CanvasItem->new ( - $self->{canvas}->get_root_item, # root? - 'GooCanvas2::CanvasGroup', + parent => $self->{canvas}->get_root_item, x => $width - $self->get_width, y => 0, ); diff --git a/t/test_spreadsheet_import.xls b/t/test_spreadsheet_import.xls index bbdeef9cc22b48b5bf95003317270faa16efe446..d272e81b898b1a6604e9d40c8e0dae0185c58348 100644 GIT binary patch delta 33 pcmZqJ!_=^cX@dq63o8Rd@n#(+hglo}yC)`V8eL)BTr#JJ5dgD!3l#tW delta 28 kcmZqJ!_=^cX@dq63l9TB@Maw*hgp+l<2W{#%;{kS0Dkre+W-In