Mercurial > bins

comparison bins-edit-gui @ 0:a84c32f131df 1.1.29

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import vendor version
author Peter Gervai <grin@grin.hu>
date Wed, 15 Oct 2008 23:28:56 +0200
parents
children
comparison
equal deleted inserted replaced
-1:000000000000 0:a84c32f131df
1 #!/usr/bin/perl
2 # bins-edit-gui -- graphical editor for BINS-format XML tag files
3 #
4 # Copyright 2002 Mark W. Eichin <eichin@thok.org>
5 # The Herd of Kittens
6 #
7 # -- GPL notice --
8 $gpl_text = <<EOF ;
9 # This program is free software; you can redistribute it and/or modify
10 # it under the terms of the GNU General Public License as published by
11 # the Free Software Foundation; either version 2 of the License, or
12 # (at your option) any later version.
13 #
14 # This program is distributed in the hope that it will be useful,
15 # but WITHOUT ANY WARRANTY; without even the implied warranty of
16 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 # GNU General Public License for more details.
18 #
19 # You should have received a copy of the GNU General Public License
20 # along with this program; if not, write to the Free Software
21 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
22 EOF
23 # -- end GPL notice --
24
25 $version = "0.9";
26
27 @album_tags = qw(title longdesc shortdesc sampleimage);
28 @image_tags = qw(title event location people date description);
29 @known_tags = sort (@album_tags, @image_tags);
30 {
31 # perlfaq4 uniquify
32 my $prev = undef;
33 @known_tags = grep($_ ne $prev && ($prev = $_, 1), @known_tags);
34 }
35 # allbery suggests
36 # keys %{{map(($_,1),@array)}}
37 # would be like the perlfaq unique-keys example...
38
39 use Getopt::Long;
40
41 use Gtk;
42 use Gtk::GladeXML;
43
44 use XML::DOM;
45 use XML::XQL;
46 use XML::XQL::DOM;
47 use XML::Writer;
48
49 use Gtk::Gdk::ImlibImage;
50 use Gnome;
51
52 use Text::Iconv;
53
54 # for localized text
55 # use POSIX qw(setlocale LC_MESSAGES); # apparently only works on Debian,
56 # mandrake, redhat, and suse are reported to need the following instead:
57 use POSIX 'locale_h';
58 use Locale::gettext;
59
60 sub _ {
61 Locale::gettext::gettext(shift);
62 }
63
64 $debug=0;
65
66 $localePath = "/usr/local/share/locale"; # Base locale path (for I18N)
67
68 setlocale(LC_MESSAGES, "");
69 bindtextdomain("bins-edit-gui", $localePath);
70 textdomain("bins-edit-gui");
71
72 sub usage {
73 my $why = shift;
74 my $usage =
75 "bins-edit-gui: [--debug] [--version] " . _("file [files...]") ."\n".
76 " "._("Edit BINS-format tags (captions, titles, etc) for image files.") ."\n".
77 "\n".
78 " --debug " . _("enable developer-only debugging.") ."\n".
79 " --version " . _("display version information.") ."\n";
80
81 if ($why eq 'error') {
82 print STDERR $usage;
83 exit 1;
84 } elsif ($why eq 'user') {
85 print STDOUT $usage;
86 exit 0;
87 }
88 }
89
90 $o_help=0;
91 $o_version=0;
92
93 $fullversion =
94 "bins-edit-gui $version " . _("for BINS") ."\n".
95 "Copyright 2002 Mark W. Eichin <eichin\@thok.org>" ."\n".
96 _("This is free software distributed under the GPL. There is NO WARRANTY.") ."\n".
97
98
99 GetOptions('debug+' => \$debug,
100 'h|help' => \$o_help,
101 'v|version' => \$o_version,
102 ) or usage('error');
103 usage('user') if $o_help;
104 if ($o_version) {
105 print $fullversion;
106 exit 0;
107 }
108
109 # take this out when we have a file browser
110 usage('error') if scalar(@ARGV) < 1;
111
112 # find a way to do this in Perl; nl_langinfo seems to be coming in 5.8
113 my $localEncoding = "";
114 my $codeset;
115 eval {
116 require I18N::Langinfo;
117 I18N::Langinfo->import(qw(langinfo CODESET));
118 $codeset = langinfo(CODESET());
119 };
120 # ANSI is unspeakably primitive, keep LATIN1 instead
121 # Solaris refers to ISO 646 as "646" but that is not a valid codeset
122 if (!$@ && $codeset && $codeset ne "ANSI_X3.4-1968" && $codeset ne "646") {
123 $localEncoding = $codeset;
124 print "Forcing encoding to $codeset";
125 }
126
127 chop($localEncoding);
128 if (! $localEncoding) {
129 $localEncoding = "LATIN1";
130 }
131 $Latin2UTF = Text::Iconv->new($localEncoding, "UTF-8");
132 $UTF2Latin = Text::Iconv->new("UTF-8", $localEncoding);
133
134 my_init_rotations();
135
136 Gtk->set_locale;
137
138 Gnome->init("bins-edit-gui", $version);
139 Gtk->init;
140
141 $glade = "/usr/local/share/bins/bins-edit-gui.glade";
142 if (! -r $glade) {
143 $glade = "bins-edit-gui.glade" ; # developer hack
144 print "DEVELOPER HACK\n";
145 if (! -r $glade) {
146 die "No bins-edit-gui.glade available";
147 }
148 }
149 #$g = new Gtk::GladeXML($glade, 'image_edit_top');
150 $g = new Gtk::GladeXML($glade);
151 die "Gtk::GladeXML($glade) initialization failed; check required packages" unless $g;
152
153 $g->signal_autoconnect_from_package('main'); # main:: so we can grab stuff directly
154
155 # get the "global" widgets
156
157 $w = $g->get_widget('image_edit_pixmap'); # GTK-Interface/widget/name
158 $w->signal_connect(expose_event => \&on_test_expose_event);
159 $name_entry = $g->get_widget("field_name_entry");
160 $value_entry = $g->get_widget("field_value_entry");
161 $ilist = $g->get_widget("image_prop_list");
162 $ilist->column_titles_passive; # shouldn't this be in the .glade?
163 # work around libglade 0.17 bug (debbugs #147051)
164 $ilist->set_column_title(0, _("Property"));
165 $ilist->set_column_title(1, _("Value"));
166 # end workaround.
167 $statusbar = $g->get_widget('statusbar1');
168 $aboutbox = $g->get_widget('about_box');
169 $aboutbox->close_hides;
170 $licensebox = $g->get_widget('license_box');
171 $licensetext = $g->get_widget('license_text'); # GtkText
172 #print ref($licensetext),": ",join("\n\t|",%Gtk::Text::),"\n";
173 $gpl_text =~ s/^\# ?//gm;
174 $licensetext->insert(undef, undef, undef, $gpl_text);
175
176 ## album-panel globals
177 $albumedit = $g->get_widget('album_edit_top');
178 $albumfile = $g->get_widget('album_edit_filename');
179 $albumprop = $g->get_widget('album_prop_list');
180 # work around libglade 0.17 bug (debbugs #147051)
181 $albumprop->set_column_title(0, _("Property"));
182 $albumprop->set_column_title(1, _("Value"));
183 # end workaround.
184 $albumname = $g->get_widget('album_name_entry');
185 $albumname->set_popdown_strings(@album_tags);
186 $albumvalue = $g->get_widget('album_edit_text');
187
188 sub on_dismiss_about_clicked {
189 $licensebox->hide;
190 status(_("Thank you for sharing."));
191 }
192
193 sub status {
194 my $msg = shift;
195 $statusbar->pop(1);
196 $statusbar->push(1, $msg);
197 }
198
199 use Image::Info;
200
201 # original orientation for viewing
202 sub get_image_orientation($) {
203 my $filename = shift;
204 # bail directly if we have a tag-loaded value
205 return $newimage_tagged_or if (defined $newimage_tagged_or);
206 # try and find a way to get this from imlib?
207 my $info = Image::Info::image_info($filename);
208 if (exists $info->{'error'}) {
209 my $msg = sprintf(_("Couldn't read EXIF info from %s: %s, ignoring."),
210 $filename, $info->{'error'});
211
212 status($msg);
213 print $msg if $debug;
214 return "top_left";
215 }
216 $info->{'Orientation'};
217 }
218
219 # see http://www.ba.wakwak.com/~tsuruzoh/Computer/Digicams/exif-e.html
220 # for the meaning of the orientations.
221 # see /usr/share/doc/imlib-base/html/index.html
222 # for the not-quite-apology for the function supplied.
223 # see the qiv sources for an example of how to use it anyway...
224
225 sub my_real_gdk_rotate($$) {
226 my ($newimage,$orientation) = @_;
227 my $degrees;
228
229 if ($orientation eq "right_top"){
230 $degrees = 90;
231 $newimage->rotate_image('a 45 degree mirror is *not* a rotate');
232 $newimage->flip_image_horizontal ();
233 } elsif ($orientation eq "left_bot"){
234 $degrees = 270;
235 $newimage->rotate_image('a 45 degree mirror is *not* a rotate');
236 $newimage->flip_image_vertical ();
237 } elsif ($orientation eq "right_bot"){
238 $degrees = 180;
239 # test this, maybe simplify...
240 $newimage->rotate_image('a 45 degree mirror is *not* a rotate');
241 $newimage->flip_image_horizontal ();
242 $newimage->rotate_image('a 45 degree mirror is *not* a rotate');
243 $newimage->flip_image_horizontal ();
244 } elsif ($orientation eq "top_left"){
245 # do nothing
246 return;
247 } else {
248 print STDERR "Warning, Orientation field has an unknown value '$orientation'.\n" if $debug;
249 # still do nothing
250 return 0;
251 }
252
253 }
254
255
256 sub load_image_tags($);
257
258 sub load_image { # no proto, we're cheating and doing 1arg/2arg (or should that be @?)
259 my $test_filename = shift;
260 my $extra = shift;
261 my $ilabel = $g->get_widget('image_filename_label');
262 $newimage->destroy_image() if defined $newimage;
263 $newimage = load_image Gtk::Gdk::ImlibImage($test_filename);
264 if (defined $newimage) {
265 if ($extra ne "keeptags") {
266 load_image_tags $test_filename;
267 $newimage_loaded_or = $newimage_or = get_image_orientation($test_filename);
268 print "$test_filename: got orientation <$newimage_or>\n" if $debug;
269 }
270 my_real_gdk_rotate($newimage,$newimage_or);
271 $ilabel->set($test_filename);
272 status(sprintf(_("Loaded %s."), $test_filename));
273 } else {
274 # no image - just skip. we've already filtered xml files, though.
275 $ilabel->set(_("Load failed: ") . $test_filename);
276 status(sprintf(_("IMLib failed loading %s."), $test_filename));
277 }
278 # regardless, rerender
279 if (defined $imagesized) {
280 undef $imagesized;
281 on_test_expose_event(); # cheat, it doesn't use it
282 }
283
284 }
285 # from bins_edit
286
287 # my $grove_builder = XML::Grove::Builder->new;
288 # my $parser = XML::Parser::PerlSAX->new ( Handler => $grove_builder );
289 # $document = $parser->parse ( Source => { SystemId => "${test_filename}.xml" } );
290
291 # now only internal for load...
292 sub load_image_tags($) {
293 %old_field = %field; # save for later recall
294
295 my $test_filename = shift;
296 $parser = new XML::DOM::Parser;
297 if (-r "${test_filename}.xml" ) {
298 $doc = $parser->parsefile ("${test_filename}.xml");
299 } else {
300 # literal minimal tree
301 $doc = $parser->parse('<?xml version="1.0" encoding="UTF-8"?><image><description></description><bins></bins><exif></exif></image>');
302 status(sprintf(_("%s not found, constructing"), "${test_filename}.xml"));
303 }
304
305
306 undef %field;
307
308 for my $i (@image_tags) {
309 $field{$i} = "";
310 }
311
312 for my $field_node ($doc->xql("image/description/field")) {
313 # <field name="location"></field>
314 # <field name="description">Sjenka</field>
315 my $fieldname = ($field_node->xql("\@name"))[0]->xql_toString;
316 my $fieldval = $field_node->xql_toString;
317 print "N: $fieldname V: $fieldval\n" if $debug;
318 my $newval;
319 do {
320 $newval = $UTF2Latin->convert($fieldval);
321 charmap_failed("load_image_tags", $fieldval) if (not defined $newval);
322 } until defined $newval;
323 $field{$fieldname} = $newval;
324 }
325
326 undef $newimage_tagged_or;
327 # <image><exif><tag name="Orientation" priority="1">right_top</tag>
328 for my $tag_node ($doc->xql("image/exif/tag[\@name = 'Orientation']")) {
329 my $tagname = ($tag_node->xql("\@name"))[0]->xql_toString;
330 my $tagprio_node = ($tag_node->xql("\@priority"))[0];
331 my $tagprio;
332 $tagprio = $tagprio_node->xql_toString if defined $tagprio_node;
333 my $tagval = $tag_node->xql_toString;
334 # but actually, we only care about orientation
335 print "N: $tagname V: $tagval P: $tagprio\n" if $debug;
336 if ($tagprio == 1) {
337 $newimage_tagged_or = $tagval;
338 }
339 }
340
341 # a clist is output only. someday, replace it with a list of
342 # editboxes, even if we have to write one all in perl.
343
344 # in the mean time, we vector out to a pair of combo boxes and let
345 # the user edit there, while copying the changes back live.
346
347 # save last index if any...
348 my $oldtag;
349 my $oldrow = $ilist->focus_row();
350 $oldtag = $ilist->get_text($oldrow, 0) if $oldrow > 0;
351 print "old $oldrow: $oldtag\n" if $debug;
352 $ilist->clear;
353 for my $i (sort keys %field) {
354 $ilist->append("\u$i", $field{$i});
355 }
356 if ($oldrow > 0) {
357 my $newrow = my_gtk_find_row($ilist, 0, $oldtag);
358 print "new $newrow\n" if $debug;
359 if ($newrow > 0) {
360 $ilist->set_focus_row($newrow);
361 $ilist->grab_focus();
362 }
363 }
364
365 # help the user enter stuff
366 $name_entry->set_popdown_strings(@known_tags);
367 # tag as unchanged
368 $dirty = 0;
369 }
370
371 sub charmap_failed($$) {
372 my $ipop = $g->get_widget('iconv_failed_dialog');
373
374 my $lbutton = $g->get_widget('iconv_latin1_charmap_button');
375 $lbutton->set_active(Gtk->true); # really we mean it
376 my $ubutton = $g->get_widget('iconv_user_charmap_button');
377 my $uentry = $g->get_widget('iconv_user_charmap_entry');
378 # if there's a value there, it is from the previous attempt, and is wrong.
379 $uentry->set_text("");
380
381 $ipop->run_and_close;
382
383 if ($lbutton->get_active) {
384 set_encoding("LATIN1");
385 } elsif ($ubutton->get_active) {
386 set_encoding($uentry->get_text);
387 }
388
389 }
390
391 sub save_image_tags {
392 my $test_filename = shift;
393 if ((not $dirty) && ($newimage_or eq $newimage_loaded_or)) {
394 status(sprintf(_("%s not dirty, not saved"), ${test_filename}));
395 return;
396 }
397
398 my $parent = ($doc->xql("image/description"))[0]; # first one
399 my $exif = ($doc->xql("image/exif"))[0];
400 my %f = %field;
401
402 # write out the tree...
403 for my $xmlfield ($doc->xql("image/description/field")) {
404 my $namestr = $xmlfield->getAttribute("name");
405 if (defined $f{$namestr}) {
406 # delete this node so we can append it later
407 $xmlfield->getParentNode->removeChild($xmlfield);
408 }
409 }
410 # now append the remaining ones...
411 for my $k (keys %f) {
412 next if ($f{$k} eq "");
413 my $newfield = new XML::DOM::Element($doc, "field");
414 print "creating <$k> with <$f{$k}>\n" if $debug;
415 $newfield->setAttribute("name", $k); # needs quoting!
416 print "k: ", $k, " f: ", $f{$k}, " L2U: ", $Latin2UTF->convert($f{$k}), "\n" if $debug;
417 my $newval;
418 do {
419 $newval = $Latin2UTF->convert($f{$k});
420 charmap_failed("save_image_tags", $f{$k}) if (not defined $newval);
421 } until defined $newval;
422
423 $newfield->addText($newval);
424 $parent->appendChild($newfield);
425 print "created $k with $f{$k}\n" if $debug;
426 }
427
428 # and orientation, if set
429 if ($newimage_or ne $newimage_loaded_or) {
430 for my $tag_node ($doc->xql("image/exif/tag[\@name = 'Orientation']")) {
431 # delete the node, then construct a new one
432 $tag_node->getParentNode->removeChild($tag_node);
433 }
434 my $newtag = new XML::DOM::Element($doc, "tag");
435 $newtag->setAttribute("name", "Orientation");
436 $newtag->setAttribute("priority", "1");
437 $newtag->addText($Latin2UTF->convert($newimage_or)); # unneeded conversion
438 $exif->appendChild($newtag);
439 print "Set orientation <$newimage_or> (loaded $newimage_loaded_or) in exif tag\n" if $debug;
440 }
441
442 $doc->printToFile("${test_filename}.xml");
443 status(sprintf(_("Saved %s."), $test_filename));
444 # undirty it
445 $dirty = 0;
446 $newimage_loaded_or = $newimage_or;
447 }
448
449 # if they enter or select a known one, snarf the value
450 $name_entry->entry->signal_connect('changed', sub {
451 my $entry = shift;
452 my $val = $field{$entry->get_text};
453 if (defined $val) {
454 $value_entry->entry->set_text($val);
455 $value_entry->entry->set_editable(Gtk->true);
456 }
457 $dirty = 1;
458 });
459
460 sub my_album_replace_text($$) {
461 my $aw = shift;
462 my $text = shift;
463 $aw->set_point(0);
464 $aw->forward_delete($albumvalue->get_length());
465 $aw->insert(undef, undef, undef, $text);
466 $aw->set_editable(Gtk->true);
467 }
468
469 # album version
470 $albumname->entry->signal_connect('changed', sub {
471 my $entry = shift;
472 my $val = $album{$entry->get_text};
473 if (defined $val) {
474 my_album_replace_text($albumvalue, $val);
475 }
476 $album_dirty = 1;
477 });
478
479 sub my_gtk_find_row { # returns row
480 my ($clist, $col, $value) = @_;
481 for my $i (0..$clist->rows) {
482 my $cell = $clist->get_text($i, $col);
483 return $i if ($cell ne "" && lc($cell) eq lc($value));
484 }
485 return -1;
486 }
487
488 # if the value changes, update the text
489 $value_entry->entry->signal_connect('changed', sub {
490 my $entry = shift;
491 my $newval = $entry->get_text;
492 my $tag = lc($name_entry->entry->get_text);
493 $field{$tag} = $newval;
494 $dirty = 1;
495 my $row = my_gtk_find_row($ilist, 0, $tag);
496 print "row: $row tag: $tag newval: $newval\n" if $debug;
497 # oh, no tag yet, add one
498 if ($row != -1) {
499 $ilist->set_text($row, 1, $newval);
500 } else {
501 # triggers select-row?
502 $ilist->append("\u$tag", $newval);
503 # update the dropdown too
504 @known_tags = sort (@known_tags, $tag);
505 $name_entry->set_popdown_strings(@known_tags);
506 # force it all back
507 $ilist->select_row($ilist->rows()-1, 0);
508 }
509 });
510 # album version
511 $albumvalue->signal_connect('changed', sub {
512 my $entry = shift;
513 my $newval = $entry->get_chars(0,-1);
514 my $tag = lc($albumname->entry->get_text);
515 $album{$tag} = $newval;
516 $dirty = 1;
517 my $row = my_gtk_find_row($albumprop, 0, $tag);
518 print "row: $row tag: $tag newval: $newval\n" if $debug;
519 # oh, no tag yet, add one
520 if ($row != -1) {
521 $albumprop->set_text($row, 1, $newval);
522 } else {
523 # triggers select-row?
524 $albumprob->append("\u$tag", $newval);
525 # update the dropdown too
526 @known_tags = sort (@known_tags, $tag);
527 $albumname->set_popdown_strings(@known_tags);
528 # force it all back
529 $albumprob->select_row($ilist->rows()-1, 0);
530 }
531 });
532
533 $ilist->signal_connect('select-row', sub {
534 my ($clist, $row, $col, $event, $udata) = @_;
535 print "list: $clist row: $row col: $col event: $event udata: $udata\n"
536 if $debug;
537 $name_entry->entry->set_text($clist->get_text($row,0));
538 $value_entry->entry->set_text($clist->get_text($row,1));
539 print "focus on $value_entry\n" if $debug;
540 $value_entry->entry->grab_focus();
541 });
542
543 # album version
544 $albumprop->signal_connect('select-row', sub {
545 my ($clist, $row, $col, $event, $udata) = @_;
546 print "list: $clist row: $row col: $col event: $event udata: $udata\n"
547 if $debug;
548 $albumname->entry->set_text($clist->get_text($row,0));
549 my_album_replace_text($albumvalue, $clist->get_text($row,1));
550 print "focus on $value_entry\n" if $debug;
551 $albumvalue->grab_focus();
552 });
553
554
555 # filter out .xml files, as we always derive them from the images
556 # (also lets us eventually use the images as database keys instead)
557 @filenames = grep (!/\.xml$/, @ARGV);
558
559 $current_n = 0;
560 $current_filename = $filenames[$current_n];
561
562 load_image $current_filename;
563
564 Gtk->main;
565
566 ## callbacks..
567 # new callbacks
568 # sgrep -o '%r\n' 'stag("HANDLER") __ etag("HANDLER") ' bins-edit-gui.glade | while read sub; do grep "$sub" bins-edit-gui.pl >/dev/null || echo "$sub"; done
569
570 sub on_save1_activate {
571 save_image_tags $current_filename;
572 }
573
574 sub on_about2_activate {
575 $aboutbox->show;
576 }
577
578 sub on_license1_activate {
579 $licensebox->show;
580 my $button = $g->get_widget('dismiss_about');
581 $button->grab_focus();
582 }
583
584 sub on_open2_activate {
585 status(_("File browser not yet implemented."));
586 }
587
588 sub on_revert1_activate {
589 load_image $current_filename;
590 status(sprintf(_("Reverted from %s."), $current_filename));
591 }
592
593 sub set_filename_index($) {
594 $current_n = shift;
595 $current_filename = $filenames[$current_n];
596 load_image $current_filename;
597 }
598
599 sub move_filename_index($) {
600 save_image_tags $current_filename;
601 my $delta = shift;
602 my $new_n = $current_n + $delta;
603
604 # clamp it
605 $new_n = 0 if $new_n < 0;
606 $new_n = $#filenames if $new_n > $#filenames;
607 if ($new_n == $current_n) {
608 # we didn't move
609 status(_("Out of filenames."));
610 } else {
611 set_filename_index($new_n);
612 }
613 }
614
615 sub on_next_file1_activate {
616 move_filename_index(+1);
617 }
618
619 sub on_prev_file1_activate {
620 move_filename_index(-1);
621 }
622
623 sub on_forward_10_activate {
624 move_filename_index(+10);
625 }
626 sub on_back_10_activate {
627 move_filename_index(-10);
628 }
629 sub on_start_of_list1_activate {
630 set_filename_index(0);
631 }
632 sub on_end_of_list1_activate {
633 set_filename_index($#filenames);
634 }
635
636
637 # auto fill from old_field
638 sub on_auto_fill1_activate {
639 for my $k (keys %old_field) {
640 if ($field{$k} eq "" && $old_field{$k} ne "") {
641 $field{$k} = $old_field{$k};
642 $dirty = 1;
643 # and change it on-screen
644 my $row = my_gtk_find_row($ilist, 0, $k);
645 if ($row != -1) {
646 print "updating row $row with $k ($field{$k})\n" if $debug;
647 $ilist->set_text($row, 1, $field{$k});
648 } # maybe warn, or add field, if not found?
649 }
650 }
651 status("Auto-filled fields.");
652 }
653
654 sub on_exit1_activate {
655 save_image_tags $current_filename;
656
657 Gtk->main_quit;
658 }
659
660 sub on_test_expose_event {
661 my($widget) = @_;
662
663 # print "otee, ",defined $imagesized,"\n";
664 # if (1 || not defined $imagesized) {
665 my $w = $g->get_widget('image_edit_pixmap'); # GTK-Interface/widget/name
666 # x,y,width,height
667 my ($alloc_x, $alloc_y, $alloc_w, $alloc_h) = @{$w->allocation};
668 my $widget_w = $alloc_w;
669 my $widget_h = $alloc_h;
670
671 if ($debug) {
672 print join("| ", @{$w->allocation});
673 print "| x: $widget_w y: $widget_h ";
674 print
675 "nw: ", $newimage->rgb_width,
676 " nh: ", $newimage->rgb_height, "\n" if defined $newimage;
677 print
678 " x/y: ",$widget_w/$widget_h,
679 " nw/x: ", $newimage->rgb_width/$widget_w,
680 " nh/y: ", $newimage->rgb_height/$widget_h,
681 "\n" if defined $newimage;
682 }
683 # print "ox: $old_x oy: $old_y ww: $widget_w wh: $widget_h I:$imagesized\n";
684 # return if same size
685 if ($old_x == $widget_w && $old_y == $widget_h) {
686 # but not if we never dealt before
687 return if (defined $imagesized);
688 }
689 if (defined $newimage) {
690 my ($use_w, $use_h) = ($newimage->rgb_width, $newimage->rgb_height);
691 my $rat_w = $use_w/$widget_w;
692 my $rat_h = $use_h/$widget_h;
693 $rat = ($rat_w > $rat_h) ? $rat_w : $rat_h;
694
695 $use_w = $use_w / $rat;
696 $use_h = $use_h / $rat;
697 $newimage->render($use_w, $use_h);
698 my $my_image = $newimage->copy_image(); # returns Gtk::Gdk::Pixmap
699 my $my_mask = $newimage->copy_mask(); # returns Gtk::Gdk::Bitmap
700 $w->set($my_image, $my_mask);
701 $my_image->imlib_free();
702 } else {
703 # come up with more clever "test pattern" later?
704 $w->set(undef, undef);
705 }
706 $old_x = $widget_w;
707 $old_y = $widget_h;
708 #undef $imagesized;
709 $imagesized = 1;
710 # }
711 }
712
713 # rotations that override, or rather compound, the EXIF values
714 # build the rotation-ring first
715 sub my_init_rotations {
716 my @rotation_order = ("right_top", "right_bot", "left_bot", "top_left");
717 my $left = $rotation_order[$#rotation_order];
718 for my $curr (@rotation_order) {
719 $rotate_right{$left} = $curr;
720 $rotate_left{$curr} = $left;
721 $left = $curr;
722 }
723 # special case none->top_left
724 $rotate_right{""} = $rotate_right{"top_left"};
725 $rotate_left{""} = $rotate_left{"top_left"};
726 }
727
728 sub my_image_rotate {
729 my $delta_or = shift;
730 print "$test_filename: new user-requested rotation $delta_or to $newimage_or\n" if $debug;
731
732 my_real_gdk_rotate($newimage,$delta_or);
733 # consider noticing that $newimage_or == $newimage_loaded_or and reverting.
734 # regardless, rerender
735 if (defined $imagesized) {
736 undef $imagesized;
737 on_test_expose_event();
738 }
739 status(_("Rotated."));
740 }
741
742 sub on_rotate_right_cw1_activate {
743 $newimage_or = $rotate_right{$newimage_or};
744 my_image_rotate("right_top");
745 }
746
747 sub on_rotate_left1_activate {
748 $newimage_or = $rotate_left{$newimage_or};
749 my_image_rotate("left_bot");
750 }
751
752 # don't actually undo the rotations, just reload - but don't lose tags
753 sub on_cancel_rotation1_activate {
754 load_image $current_filename, "keeptags";
755 status(_("Image restored."));
756 }
757
758 ### album stuff ###
759 sub load_album_tags($);
760
761 sub on_album1_activate {
762 $current_album = $current_filename;
763 # basename
764 $current_album =~ s{[^/]*$}{}; # } perl-mode-sucks
765 # make a complete name out of it
766 $current_album .= "album.xml"; #if (-d "${current_album}");
767 $albumfile->set($current_album);
768 load_album_tags($current_album);
769 $albumedit->show;
770 }
771
772 sub on_open2_activate {
773 status(_("File browser not yet implemented."));
774 }
775
776 sub on_close1_activate {
777 # save if dirty
778 save_album_tags($current_album) if $album_dirty;
779 $albumedit->hide;
780 }
781
782 sub on_revert2_activate {
783 load_album_tags $current_album;
784 status(sprintf(_("Reverted from %s."), $current_album));
785 }
786
787 sub save_album_tags;
788
789 sub on_save2_activate {
790 save_album_tags $current_album;
791 }
792
793 # sub on_exit2_activate {
794 # &on_exit1_activate(@_);
795 # }
796
797 sub load_album_tags($) {
798 %old_album = %album; # save for later recall
799
800 my $test_filename = shift;
801 $parser = new XML::DOM::Parser;
802 if (-r "${test_filename}" ) {
803 $album_doc = $parser->parsefile ("${test_filename}");
804 } else {
805 # literal minimal tree
806 $album_doc = $parser->parse('<?xml version="1.0" encoding="UTF-8"?><album><description></description><bins></bins></album>');
807 status(sprintf(_("%s not found, constructing"), "${test_filename}"));
808 }
809
810
811 undef %album;
812
813 for my $i (@album_tags) {
814 $album{$i} = "";
815 }
816
817 for my $field_node ($album_doc->xql("album/description/field")) {
818 my $fieldname = ($field_node->xql("\@name"))[0]->xql_toString;
819 my $fieldval = $field_node->xql_toString;
820 print "N: $fieldname V: $fieldval\n" if $debug;
821 $album{$fieldname} = $UTF2Latin->convert($fieldval);
822 }
823
824 # a clist is output only. someday, replace it with a list of
825 # editboxes, even if we have to write one all in perl.
826
827 # in the mean time, we vector out to a pair of combo boxes and let
828 # the user edit there, while copying the changes back live.
829
830 # save last index if any...
831 my $oldtag;
832 my $oldrow = $albumprop->focus_row();
833 $oldtag = $albumprop->get_text($oldrow, 0) if $oldrow > 0;
834 print "old $oldrow: $oldtag\n" if $debug;
835 $albumprop->clear;
836 for my $i (sort keys %album) {
837 $albumprop->append("\u$i", $album{$i});
838 }
839 if ($oldrow > 0) {
840 my $newrow = my_gtk_find_row($albumprop, 0, $oldtag);
841 print "new $newrow\n" if $debug;
842 if ($newrow > 0) {
843 $albumprop->set_focus_row($newrow);
844 $albumprop->grab_focus();
845 }
846 }
847
848 # help the user enter stuff
849 $albumname->set_popdown_strings(@known_tags);
850 # tag as unchanged
851 $dirty = 0;
852 }
853
854 sub save_album_tags {
855 my $test_filename = shift;
856 if (not $album_dirty) {
857 status(sprintf(_("%s not dirty, not saved"), ${test_filename}));
858 return;
859 }
860
861 my $parent = ($album_doc->xql("album/description"))[0]; # first one
862 my %f = %album;
863
864 # write out the tree...
865 for my $xmlfield ($album_doc->xql("album/description/field")) {
866 my $namestr = $xmlfield->getAttribute("name");
867 if (defined $f{$namestr}) {
868 # delete this node so we can append it later
869 $xmlfield->getParentNode->removeChild($xmlfield);
870 }
871 }
872 # now append the remaining ones...
873 for my $k (keys %f) {
874 next if ($f{$k} eq "");
875 my $newfield = new XML::DOM::Element($album_doc, "field");
876 print "creating <$k> with <$f{$k}>\n" if $debug;
877 $newfield->setAttribute("name", $k); # needs quoting!
878 $newfield->addText($Latin2UTF->convert($f{$k}));
879 $parent->appendChild($newfield);
880 print "created $k with $f{$k}\n" if $debug;
881 }
882
883 $album_doc->printToFile("${test_filename}");
884 status(sprintf(_("Saved %s."), $test_filename));
885 # undirty it
886 $album_dirty = 0;
887 }