monotone

monotone Mtn Source Tree

Root/Common.pm

1##############################################################################
2#
3# File Name - Common.pm
4#
5# Description - The common module for the mtn-browse application. This
6# module contains assorted general purpose routines used
7# throughout the application.
8#
9# Author - A.E.Cooper.
10#
11# Legal Stuff - Copyright (c) 2007 Anthony Edward Cooper
12# <aecooper@coosoft.plus.com>.
13#
14# This program is free software; you can redistribute it
15# and/or modify it under the terms of the GNU General Public
16# License as published by the Free Software Foundation;
17# either version 3 of the License, or (at your option) any
18# later version.
19#
20# This program is distributed in the hope that it will be
21# useful, but WITHOUT ANY WARRANTY; without even the implied
22# warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
23# PURPOSE. See the GNU General Public License for more
24# details.
25#
26# You should have received a copy of the GNU General Public
27# License along with this software; if not, write to the Free
28# Software Foundation, Inc., 59 Temple Place - Suite 330,
29# Boston, MA 02111-1307 USA.
30#
31##############################################################################
32#
33##############################################################################
34#
35# Global Data For This Module
36#
37##############################################################################
38
39
40
41# ***** DIRECTIVES *****
42
43require 5.008;
44
45use strict;
46use warnings;
47
48# ***** GLOBAL DATA DECLARATIONS *****
49
50# Constants for various parameters used in detecting binary data.
51
52use constant CHUNK_SIZE => 10240;
53use constant THRESHOLD => 20;
54
55# ***** FUNCTIONAL PROTOTYPES *****
56
57# Public routines.
58
59sub cache_extra_file_info($$$);
60sub colour_to_string($);
61sub create_format_tags($);
62sub data_is_binary($);
63sub file_glob_to_regexp($);
64sub generate_tmp_path($);
65sub get_branch_revisions($$$$$);
66sub get_dir_contents($$$);
67sub get_file_details($$$$$$);
68sub get_revision_ids($$;$);
69sub glade_signal_autoconnect($$);
70sub handle_comboxentry_history($$;$);
71sub hex_dump($);
72sub open_database($$$);
73sub run_command($@);
74sub save_as_file($$$);
75sub set_label_value($$);
76#
77##############################################################################
78#
79# Routine - generate_tmp_path
80#
81# Description - Generate a unique and temporary path for the specified file
82# name. The file name is included in the result and will be
83# unchanged.
84#
85# Data - $file_name : The file name component that is to be used.
86# Return Value : The full, unique, temporary path on success,
87# otherwise undef on failure.
88#
89##############################################################################
90
91
92
93sub generate_tmp_path($)
94{
95
96 my $file_name = $_[0];
97
98 my($path,
99 $i);
100
101 # Loop through looking for a temporary subdirectory not containing the
102 # specified file.
103
104 for ($i = 0; ; ++ $i)
105 {
106if (-d ($tmp_dir . "/" . $i))
107{
108 if (! -e ($path = $tmp_dir . "/" . $i . "/" . $file_name))
109 {
110return $path;
111 }
112}
113else
114{
115 return unless mkdir($tmp_dir . "/" . $i);
116 return $tmp_dir . "/" . $i . "/" . $file_name;
117}
118 }
119
120 return;
121
122}
123#
124##############################################################################
125#
126# Routine - run_command
127#
128# Description - Run the specified command and return its output.
129#
130# Data - $buffer : A reference to the buffer that is to contain
131# the output from the command.
132# $args : A list containing the command to run and its
133# arguments.
134# Return Value : True if the command worked, otherwise false
135# if something went wrong.
136#
137##############################################################################
138
139
140
141sub run_command($@)
142{
143
144 my($buffer, @args) = @_;
145
146 my(@err,
147 $fd_err,
148 $fd_in,
149 $fd_out,
150 $pid,
151 $ret_val,
152 $status,
153 $stop,
154 $total_bytes,
155 $watcher);
156
157 # Run the command.
158
159 $fd_err = gensym();
160 eval
161 {
162$pid = open3($fd_in, $fd_out, $fd_err, @args);
163 };
164 if ($@ ne "")
165 {
166my $dialog = Gtk2::MessageDialog->new
167 (undef,
168 ["modal"],
169 "warning",
170 "close",
171 __x("The {name} subprocess could not start,\n"
172 . "the system gave:\n<b><i>{error_message}</b></i>",
173 name => Glib::Markup::escape_text($args[0]),
174 error_message => Glib::Markup::escape_text($@)));
175WindowManager->instance()->allow_input(sub { $dialog->run(); });
176$dialog->destroy();
177return;
178 }
179
180 # Setup a watch handler to get read our data and handle GTK2 events whilst
181 # the command is running.
182
183 $stop = $total_bytes = 0;
184 $$buffer = "";
185 $watcher = Gtk2::Helper->add_watch
186(fileno($fd_out), "in",
187 sub {
188 my $bytes_read;
189 if (($bytes_read = sysread($fd_out,
190$$buffer,
19132768,
192$total_bytes))
193 == 0)
194 {
195 $stop = 1;
196 }
197 else
198 {
199 $total_bytes += $bytes_read;
200 }
201 return TRUE;
202 });
203 while (! $stop)
204 {
205Gtk2->main_iteration();
206 }
207 Gtk2::Helper->remove_watch($watcher);
208
209 # Get any error output.
210
211 @err = readline($fd_err);
212
213 close($fd_in);
214 close($fd_out);
215 close($fd_err);
216
217 # Reap the process and deal with any errors.
218
219 if (($ret_val = waitpid($pid, 0)) == -1)
220 {
221if ($! != ECHILD)
222{
223 my $dialog = Gtk2::MessageDialog->new_with_markup
224(undef,
225 ["modal"],
226 "warning",
227 "close",
228 __x("waitpid failed with:\n<b><i>{error_message}</i></b>",
229 error_message => Glib::Markup::escape_text($!)));
230 WindowManager->instance()->allow_input(sub { $dialog->run(); });
231 $dialog->destroy();
232 return;
233}
234 }
235 $status = $?;
236 if (WIFEXITED($status) && WEXITSTATUS($status) != 0)
237 {
238my $dialog = Gtk2::MessageDialog->new_with_markup
239 (undef,
240 ["modal"],
241 "warning",
242 "close",
243 __x("The {name} subprocess failed with an exit status\n"
244 . "of {exit_code} and printed the following on stderr:\n"
245 . "<b><i>{error_message}</i></b>",
246 name => Glib::Markup::escape_text($args[0]),
247 exit_code => WEXITSTATUS($status),
248 error_message => Glib::Markup::escape_text(join("", @err))));
249WindowManager->instance()->allow_input(sub { $dialog->run(); });
250$dialog->destroy();
251return;
252 }
253 elsif (WIFSIGNALED($status))
254 {
255my $dialog = Gtk2::MessageDialog->new
256 (undef,
257 ["modal"],
258 "warning",
259 "close",
260 __x("The {name} subprocess was terminated by signal {number}.",
261 name => Glib::Markup::escape_text($args[0]),
262 number => WTERMSIG($status)));
263WindowManager->instance()->allow_input(sub { $dialog->run(); });
264$dialog->destroy();
265return;
266 }
267
268 return 1;
269
270}
271#
272##############################################################################
273#
274# Routine - get_dir_contents
275#
276# Description - Given a path and a Monotone manifest, return a subset of
277# the manifest that represents the contents of just that
278# directory along with the directory entry names.
279#
280# Data - $path : The path to the directory from the top level of
281# the manifest.
282# $manifest : A reference to a Monotone manifest.
283# $result : A reference to a list that is to contain the
284# result (a list of records containing the short
285# directory entry name and a reference to the
286# related manifest entry).
287#
288##############################################################################
289
290
291
292sub get_dir_contents($$$)
293{
294
295 my($path, $manifest, $result) = @_;
296
297 my($entry,
298 $extract_re,
299 $match_re,
300 $name);
301
302 if ($path eq "")
303 {
304$match_re = qr/^[^\/]+$/;
305$extract_re = qr/^([^\/]+)$/;
306 }
307 else
308 {
309$match_re = qr/^${path}\/[^\/]+$/;
310$extract_re = qr/^${path}\/([^\/]+)$/;
311 }
312 @$result = ();
313 foreach $entry (@$manifest)
314 {
315if ($entry->{name} =~ m/$match_re/)
316{
317 ($name) = ($entry->{name} =~ m/$extract_re/);
318 push(@$result, {manifest_entry => $entry, name => $name});
319}
320 }
321
322}
323#
324##############################################################################
325#
326# Routine - open_database
327#
328# Description - Allows the user to select a Monotone Database and then
329# opens it, making sure that it is a valid database or
330# dealing with the consequences if it isn't.
331#
332# Data - $parent : The parent window for any dialogs that are
333# to be displayed.
334# $mtn : A reference to a variable that is to contain
335# the newly created Monotone::AutomateStdio
336# object. This parameter can be undef if the
337# object is not required.
338# $file_name : A reference to a variable that is to contain
339# the full file name of the selected database.
340# This parameter can be undef if the file name
341# is not required.
342# Return Value : True on success, otherwise false on
343# cancellation.
344#
345##############################################################################
346
347
348
349sub open_database($$$)
350{
351
352 my($parent, $mtn, $file_name) = @_;
353
354 my($chooser_dialog,
355 $done,
356 $ret_val);
357
358 $chooser_dialog = Gtk2::FileChooserDialog->new(__("Open Database"),
359 $parent,
360 "open",
361 "gtk-cancel" => "cancel",
362 "gtk-open" => "ok");
363
364 do
365 {
366if ($chooser_dialog->run() eq "ok")
367{
368
369 my ($err,
370$fh,
371$fname,
372$mtn_obj);
373
374 $fname = $chooser_dialog->get_filename();
375
376 # The user has selected a file. First make sure we can open it for
377 # reading (I know I could use the -r test but this takes care of
378 # any other unforeseen access problems as well).
379
380 if (! defined($fh = IO::File->new($fname, "r")))
381 {
382my $dialog = Gtk2::MessageDialog->new
383 ($parent,
384 ["modal"],
385 "warning",
386 "close",
387 $! . ".");
388$dialog->run();
389$dialog->destroy();
390 }
391 else
392 {
393
394$fh->close();
395$fh = undef;
396
397# Ok it is a readable file, try and open it but deal with any
398# errors in a nicer way than normal.
399
400Monotone::AutomateStdio->register_error_handler
401 (MTN_SEVERITY_ALL);
402eval
403{
404 $mtn_obj = Monotone::AutomateStdio->new($fname);
405};
406$err = $@;
407Monotone::AutomateStdio->register_error_handler
408 (MTN_SEVERITY_ALL, \&mtn_error_handler);
409if ($err ne "")
410{
411 my $dialog = Gtk2::MessageDialog->new
412($parent,
413 ["modal"],
414 "warning",
415 "close",
416 __("Not a valid Monotone database."));
417 $dialog->run();
418 $dialog->destroy();
419}
420else
421{
422
423 # Seems to be ok so tell the caller.
424
425 $$mtn = $mtn_obj if (defined($mtn));
426 $$file_name = $fname if (defined($file_name));
427 $done = $ret_val = 1;
428
429}
430
431 }
432
433}
434else
435{
436 $done = 1;
437}
438 }
439 while (! $done);
440
441 $chooser_dialog->destroy();
442
443 return $ret_val;
444
445}
446#
447##############################################################################
448#
449# Routine - save_as_file
450#
451# Description - Allows the user to save the specified data as a file on
452# disk.
453#
454# Data - $parent : The parent window for any dialogs that are to
455# be displayed.
456# $file_name : The suggested name of the file that is to be
457# saved.
458# $data : A reference to a variable containing the raw
459# file data.
460#
461##############################################################################
462
463
464
465sub save_as_file($$$)
466{
467
468 my($parent, $file_name, $data) = @_;
469
470 my($chooser_dialog,
471 $continue,
472 $done);
473
474 $chooser_dialog = Gtk2::FileChooserDialog->new(__("Save As"),
475 $parent,
476 "save",
477 "gtk-cancel" => "cancel",
478 "gtk-save" => "ok");
479 $chooser_dialog->set_current_name
480($file_name) if ($file_name ne "");
481
482 do
483 {
484if ($chooser_dialog->run() eq "ok")
485{
486
487 my ($fh,
488$fname);
489
490 $continue = 1;
491 $fname = $chooser_dialog->get_filename();
492
493 # See if the file exists, if so then get a confirmation from the
494 # user.
495
496 if (-e $fname)
497 {
498my $dialog = Gtk2::MessageDialog->new
499 ($parent,
500 ["modal"],
501 "question",
502 "yes-no",
503 __("File already exists.\nDo you want to replace it?"));
504$dialog->set_title(__("Confirm"));
505$continue = 0 if ($dialog->run() ne "yes");
506$dialog->destroy();
507 }
508
509 if ($continue)
510 {
511
512# Attempt to save the contents to the file.
513
514if (! defined($fh = IO::File->new($fname, "w")))
515{
516 my $dialog = Gtk2::MessageDialog->new
517($parent,
518 ["modal"],
519 "warning",
520 "close",
521 __x("{error_message}.", error_message => $!));
522 $dialog->run();
523 $dialog->destroy();
524}
525else
526{
527 $fh->print($$data);
528 $fh->close();
529 $done = 1;
530}
531
532 }
533
534}
535else
536{
537 $done = 1;
538}
539 }
540 while (! $done);
541
542 $chooser_dialog->destroy();
543
544}
545#
546##############################################################################
547#
548# Routine - get_branch_revisions
549#
550# Description - Get a list of revision ids or tags for the specified branch
551# that take into account the user's preferences for ordering
552# and the maximum number of revisions to display.
553#
554# Data - $mtn : The Monotone::AutomateStdio object that is to
555# be used.
556# $branch : The name of the branch that revisions are to
557# be found for.
558# $tags : True if the list of revisions are to be tags,
559# otherwise false if they are to be ids.
560# $appbar : If defined, the application progress bar
561# widget that is to be updated with the progress
562# of this operation. It is assumed that the
563# progress is set at 0 and will end up being set
564# to 1.
565# $revisions : A reference to a list that is to contain the
566# resultant list of sorted revision tags or ids.
567#
568##############################################################################
569
570
571
572sub get_branch_revisions($$$$$)
573{
574
575 my($mtn, $branch, $tags, $appbar, $revisions) = @_;
576
577 @$revisions = ();
578
579 if ($tags)
580 {
581
582my(%rev_id_to_tags,
583 %seen,
584 @sorted_rev_ids,
585 @tags);
586
587# Get the list of revision tags.
588
589$mtn->tags(\@tags, $branch);
590$appbar->set_progress_percentage(0.5) if (defined($appbar));
591WindowManager->update_gui();
592
593# Does the list need truncating (in which case we need to sort by date
594# to keep the most recent tags) or does the user want to sort tags by
595# date?
596
597if (($user_preferences->{query}->{tagged}->{limit} > 0
598 && scalar(@tags) > $user_preferences->{query}->{tagged}->{limit})
599 || $user_preferences->{query}->{tagged}->{sort_cronologically})
600{
601
602 # Yes tags are to be either sorted by date or need to be truncated
603 # (requiring them to temporarily be sorted by date).
604
605 # Build up a hash mapping revision id to tag(s).
606
607 foreach my $tag (@tags)
608 {
609if (exists($rev_id_to_tags{$tag->{revision_id}}))
610{
611 push(@{$rev_id_to_tags{$tag->{revision_id}}}, $tag->{tag});
612}
613else
614{
615 $rev_id_to_tags{$tag->{revision_id}} = [$tag->{tag}];
616}
617 }
618
619 # Sort the revision ids into date order (youngest first).
620
621 $mtn->toposort(\@sorted_rev_ids, keys(%rev_id_to_tags));
622 @sorted_rev_ids = reverse(@sorted_rev_ids);
623
624 # Now build up a list of tags based on this ordering, deduping
625 # items and stopping when we have enough tags.
626
627 revision: foreach my $rev_id (@sorted_rev_ids)
628 {
629foreach my $tag (sort(@{$rev_id_to_tags{$rev_id}}))
630{
631 push(@$revisions, $tag) if (! $seen{$tag} ++);
632 last revision
633if ($user_preferences->{query}->{tagged}->{limit} > 0
634 && scalar(@$revisions) >=
635 $user_preferences->{query}->{tagged}->{limit});
636}
637 }
638
639}
640else
641{
642
643 # No tags are to be sorted by name, without truncation.
644
645 # At this stage simply extract the tags and dedupe them.
646
647 @$revisions = map($_->{tag}, grep(! $seen{$_->{tag}} ++, @tags));
648
649}
650
651# We now have a list of tags in @$revisions of the correct size and
652# sorted by date if so required by the user. So resort the list
653# aplhabetically if required.
654
655@$revisions = sort(@$revisions)
656 if (! $user_preferences->{query}->{tagged}->{sort_cronologically});
657
658 }
659 else
660 {
661
662# Get the list of revision ids, if no branch is specified then get all
663# of the revisions within the database.
664
665$mtn->select($revisions,
666 ((defined($branch) && $branch ne "") ? "b:" : "i:")
667 . $branch);
668
669# Does it need truncating?
670
671if ($user_preferences->{query}->{id}->{limit} == 0
672 || scalar(@$revisions)
673 <= $user_preferences->{query}->{id}->{limit})
674{
675
676 # No so simply sort it.
677
678 if ($user_preferences->{query}->{id}->{sort_cronologically})
679 {
680$appbar->set_progress_percentage(0.33) if (defined($appbar));
681WindowManager->update_gui();
682$mtn->toposort($revisions, @$revisions);
683$appbar->set_progress_percentage(0.66) if (defined($appbar));
684WindowManager->update_gui();
685@$revisions = reverse(@$revisions);
686 }
687 else
688 {
689$appbar->set_progress_percentage(0.5) if (defined($appbar));
690WindowManager->update_gui();
691@$revisions = sort(@$revisions);
692 }
693
694}
695else
696{
697
698 # Yes so truncate and then sort it.
699
700 $appbar->set_progress_percentage(0.33) if (defined($appbar));
701 WindowManager->update_gui();
702 $mtn->toposort($revisions, @$revisions);
703 $appbar->set_progress_percentage(0.66) if (defined($appbar));
704 splice(@$revisions,
705 0,
706 scalar(@$revisions)
707 - $user_preferences->{query}->{id}->{limit});
708 if ($user_preferences->{query}->{id}->{sort_cronologically})
709 {
710@$revisions = reverse(@$revisions);
711 }
712 else
713 {
714@$revisions = sort(@$revisions);
715 }
716
717}
718
719 }
720
721 $appbar->set_progress_percentage(1) if (defined($appbar));
722 WindowManager->update_gui();
723
724}
725#
726##############################################################################
727#
728# Routine - get_revision_ids
729#
730# Description - Return the currently selected revision id, whether this is
731# specified via a tag or as a revision id.
732#
733# Data - $instance : The window instance.
734# $revision_ids : A reference to a list that is to contain
735# the revision ids. Normally the list will
736# have at most one element but may contain
737# more if the tag isn't unique on the current
738# branch.
739# $tag : A reference to a variable that is to
740# contain the tag name that the user selected
741# or undef if the user selected a revision id
742# directly. This is optional.
743#
744##############################################################################
745
746
747
748sub get_revision_ids($$;$)
749{
750
751 my($instance, $revision_ids, $tag) = @_;
752
753 @$revision_ids=();
754 $$tag = undef if (defined($tag));
755 return unless ($instance->{revision_combo_details}->{complete});
756 if ($instance->{tagged_checkbutton}->get_active())
757 {
758$instance->{mtn}->
759 select($revision_ids,
760 "t:" . $instance->{revision_combo_details}->{value});
761$$tag = $instance->{revision_combo_details}->{value}
762 if (defined($tag));
763 }
764 else
765 {
766push(@$revision_ids, $instance->{revision_combo_details}->{value});
767 }
768
769}
770#
771##############################################################################
772#
773# Routine - cache_extra_file_info
774#
775# Description - Cache extra information about a file in its manifest entry
776# record.
777#
778# Data - $mtn : The Monotone::AutomateStdio object that
779# is to be used.
780# $revision_id : The revision id from where the search for
781# the latest file update is to start,
782# working backwards.
783# $manifest_entry : A reference to the file's manifest entry.
784#
785##############################################################################
786
787
788
789sub cache_extra_file_info($$$)
790{
791
792 my($mtn, $revision_id, $manifest_entry) = @_;
793
794 get_file_details($mtn,
795 $revision_id,
796 $manifest_entry->{name},
797 \$manifest_entry->{author},
798 \$manifest_entry->{last_update},
799 \$manifest_entry->{last_changed_revision});
800
801}
802#
803##############################################################################
804#
805# Routine - get_file_details
806#
807# Description - Get the details of the specified file.
808#
809# Data - $mtn : The Monotone::AutomateStdio object
810# that is to be used.
811# $revision_id : The revision id from where the
812# search for the latest file update
813# is to start, working backwards.
814# $file_name : The full path name of the file.
815# $author : A reference to the variable that
816# is to contain the author's
817# identity.
818# $last_update : A reference to the variable that
819# is to contain the last updated
820# date for the file.
821# $last_changed_revision : A reference to the variable that
822# is to contain the revision id on
823# which the file was last updated.
824#
825##############################################################################
826
827
828
829sub get_file_details($$$$$$)
830{
831
832 my($mtn,
833 $revision_id,
834 $file_name,
835 $author,
836 $last_update,
837 $last_changed_revision) = @_;
838
839 my(@certs_list,
840 @revision_list);
841
842 $mtn->get_content_changed(\@revision_list, $revision_id, $file_name);
843 $$last_changed_revision = $revision_list[0];
844 $mtn->certs(\@certs_list, $revision_list[0]);
845 $$author = $$last_update = "";
846 foreach my $cert (@certs_list)
847 {
848if ($cert->{name} eq "author")
849{
850 $$author = $cert->{value};
851}
852elsif ($cert->{name} eq "date")
853{
854 $$last_update = $cert->{value};
855}
856last if ($$author ne "" && $$last_update ne "");
857 }
858
859}
860#
861##############################################################################
862#
863# Routine - file_glob_to_regexp
864#
865# Description - Converts the specified string containing a file name style
866# glob into a regular expression.
867#
868# Data - $file_glob : The file name wildcard that is to be
869# converted.
870# Return Value : The resultant regular expression string.
871#
872##############################################################################
873
874
875
876sub file_glob_to_regexp($)
877{
878
879 my $file_glob = $_[0];
880
881 my($escaping,
882 $first,
883 $re_text);
884
885 $escaping = 0;
886 $first = 1;
887 $re_text = "^";
888 foreach my $char (split(//, $file_glob))
889 {
890if ($first)
891{
892 $re_text .= "(?=[^\\.])" unless $char eq ".";
893 $first = 0;
894}
895if (".+^\$\@%()|" =~ m/\Q$char\E/)
896{
897 $re_text .= "\\" . $char;
898}
899elsif ($char eq "*")
900{
901 $re_text .= $escaping ? "\\*" : "[^/]*";
902}
903elsif ($char eq "?")
904{
905 $re_text .= $escaping ? "\\?" : "[^/]";
906}
907elsif ($char eq "\\")
908{
909 if ($escaping)
910 {
911$re_text .= "\\\\";
912$escaping = 0;
913 }
914 else
915 {
916$escaping = 1;
917 }
918}
919else
920{
921 $re_text .= "\\" if ($escaping && $char eq "[");
922 $re_text .= $char;
923 $escaping = 0;
924}
925 }
926 $re_text .= "\$";
927
928 return $re_text;
929
930}
931#
932##############################################################################
933#
934# Routine - handle_comboxentry_history
935#
936# Description - Handle comboboxentry histories. Histories are limited to a
937# small fixed value and are stored to disk in the user's
938# preferences file.
939#
940# Data - $widget : The comboboxentry that is to be updated.
941# $history_name : The name of the history list that is to be
942# updated or loaded.
943# $value : The new value that is to be added to the
944# specified history list and comboboxentry or
945# undef if the comboboxentry is just to
946# updated with the current history list. This
947# is optional.
948#
949##############################################################################
950
951
952
953sub handle_comboxentry_history($$;$)
954{
955
956 my($widget, $history_name, $value) = @_;
957
958 my $update_history = 1;
959 my $history_ref = $user_preferences->{histories}->{$history_name};
960
961 # Update the comboxentry history list and save it to disk.
962
963 if (defined($value))
964 {
965if ($value ne "")
966{
967 foreach my $entry (@$history_ref)
968 {
969if ($entry eq $value)
970{
971 $update_history = 0;
972last;
973}
974 }
975}
976else
977{
978 $update_history = 0;
979}
980if ($update_history)
981{
982 splice(@$history_ref, $user_preferences->{history_size})
983if (unshift(@$history_ref, $value) >
984 $user_preferences->{history_size});
985 eval
986 {
987save_preferences($user_preferences);
988 };
989 if ($@ ne "")
990 {
991chomp($@);
992my $dialog = Gtk2::MessageDialog->new
993 (undef,
994 ["modal"],
995 "warning",
996 "close",
997 __("Your preferences could not be saved:\n") . $@);
998$dialog->run();
999$dialog->destroy();
1000 }
1001}
1002 }
1003
1004 # Update the comboboxentry itself if necessary.
1005
1006 if ($update_history)
1007 {
1008$widget->get_model()->clear();
1009foreach my $entry (@$history_ref)
1010{
1011 $widget->append_text($entry);
1012}
1013 }
1014
1015}
1016#
1017##############################################################################
1018#
1019# Routine - create_format_tags
1020#
1021# Description - Creates the Gtk2::TextBuffer tags that are used to pretty
1022# print stuff.
1023#
1024# Data - $text_view : The GTK2::TextBuffer widget that is to have
1025# its tags created.
1026#
1027##############################################################################
1028
1029
1030
1031sub create_format_tags($)
1032{
1033
1034 my $text_buffer = $_[0];
1035
1036 my $colours = $user_preferences->{colours};
1037
1038 # Normal Black text, assorted styles, on a white background.
1039
1040 $text_buffer->create_tag("normal", "weight" => PANGO_WEIGHT_NORMAL);
1041
1042 $text_buffer->create_tag("bold", "weight" => PANGO_WEIGHT_BOLD);
1043 $text_buffer->create_tag("italics", "style" => "italic");
1044 $text_buffer->create_tag("bold-italics",
1045 "weight" => PANGO_WEIGHT_BOLD,
1046 "style" => "italic");
1047
1048 # Set up the colour and style schemes for file comparison and annotation.
1049
1050 foreach my $i (1 .. 2)
1051 {
1052my $clr = $user_preferences->{colours}->{"cmp_revision_" . $i};
1053$text_buffer->create_tag("compare-" . $i,
1054 "foreground" => $clr->{fg});
1055$text_buffer->create_tag("bold-compare-" . $i,
1056 "weight" => PANGO_WEIGHT_BOLD,
1057 "foreground" => $clr->{fg});
1058$text_buffer->create_tag("italics-compare-" . $i,
1059 "style" => "italic",
1060 "foreground" => $clr->{fg});
1061$text_buffer->create_tag("bold-italics-compare-" . $i,
1062 "weight" => PANGO_WEIGHT_BOLD,
1063 "style" => "italic",
1064 "foreground" => $clr->{fg});
1065$text_buffer->create_tag("compare-file-" . $i,
1066 "foreground" => $clr->{fg},
1067 "background" => $clr->{bg});
1068$text_buffer->create_tag("compare-file-info-" . $i,
1069 "weight" => PANGO_WEIGHT_BOLD,
1070 "foreground" => $clr->{hl},
1071 "background" => "DarkSlateGrey");
1072foreach my $prefix ("annotate_prefix_", "annotate_text_")
1073{
1074 my $tag = $prefix;
1075 $tag =~ s/_/-/g;
1076 $clr = $user_preferences->{colours}->{$prefix . $i};
1077 $text_buffer->create_tag($tag . $i,
1078 "foreground" => $clr->{fg},
1079 "background" => $clr->{bg});
1080}
1081 }
1082
1083 # Yellow text on a grey background.
1084
1085 $text_buffer->create_tag("compare-info",
1086 "foreground" => "Yellow",
1087 "background" => "LightSlateGrey");
1088
1089}
1090#
1091##############################################################################
1092#
1093# Routine - hex_dump
1094#
1095# Description - Generates a hexadecimal dump of the specified data.
1096#
1097# Data - $data : A reference to the data that is to be hex
1098# dumped.
1099# Return Value : A reference to the resultant hex dump as a
1100# string.
1101#
1102##############################################################################
1103
1104
1105
1106sub hex_dump($)
1107{
1108
1109 my $data = $_[0];
1110
1111 my ($buffer,
1112$counter,
1113@line);
1114
1115 $counter = 0;
1116 foreach my $byte (split(//, $$data))
1117 {
1118++ $counter;
1119push(@line, $byte);
1120$buffer .= sprintf("%02X ", ord($byte));
1121$buffer .= " " if (($counter % 8) == 0);
1122if (($counter % 16) == 0)
1123{
1124 foreach my $byte2 (@line)
1125 {
1126$buffer .= ($byte2 =~ m/[[:print:]]/) ? (" " . $byte2) : " .";
1127 }
1128 $buffer .= "\n";
1129 @line = ();
1130}
1131 }
1132
1133 # If the last line is incomplete then finish it off.
1134
1135 if (scalar(@line) > 0)
1136 {
1137$buffer .= " " x (16 - scalar(@line));
1138$buffer .= " " if (scalar(@line) < 8);
1139$buffer .= " ";
1140foreach my $byte2 (@line)
1141{
1142 $buffer .= ($byte2 =~ m/[[:print:]]/) ? (" " . $byte2) : " .";
1143}
1144$buffer .= "\n";
1145 }
1146
1147 return \$buffer;
1148
1149}
1150#
1151##############################################################################
1152#
1153# Routine - data_is_binary
1154#
1155# Description - Determines whether the specified string contains binary
1156# data.
1157#
1158# Data - $data : A reference to the data that is to be
1159# tested.
1160# Return Value : True if the data is binary, otherwise false
1161# if it is predominantly textual.
1162#
1163##############################################################################
1164
1165
1166
1167sub data_is_binary($)
1168{
1169
1170 my $data = $_[0];
1171
1172 my($chunk,
1173 $length,
1174 $non_printable,
1175 $offset,
1176 $total_length);
1177
1178 $offset = 0;
1179 $total_length = length($$data);
1180 while ($offset < $total_length)
1181 {
1182$chunk = substr($$data, $offset, CHUNK_SIZE);
1183$offset += CHUNK_SIZE;
1184$length = length($chunk);
1185$non_printable = grep(/[^[:print:][:space:]]/, split(//, $chunk));
1186return 1 if (((100 * $non_printable) / $length) > THRESHOLD);
1187 }
1188 return;
1189
1190}
1191#
1192##############################################################################
1193#
1194# Routine - colour_to_string
1195#
1196# Description - Returns a string representing the specified
1197# Gtk2::Gdk::Color value.
1198#
1199# Data - $colour : A Gtk2::Gdk::Color object.
1200# Return Value : A string containing the colour value.
1201#
1202##############################################################################
1203
1204
1205
1206sub colour_to_string($)
1207{
1208
1209 my $colour = $_[0];
1210
1211 return sprintf("#%02X%02X%02X",
1212 ($colour->red() >> 8) & 0xff,
1213 ($colour->green() >> 8) & 0xff,
1214 ($colour->blue() >> 8) & 0xff);
1215
1216}
1217#
1218##############################################################################
1219#
1220# Routine - set_label_value
1221#
1222# Description - Set the text for the given label and the tooltip for the
1223# parent widget, assumed to be an event box, to the specified
1224# text.
1225#
1226# Data - $widget : The label widget that has an event box as its
1227# parent.
1228# $value : The text that the label and tooltip are to be set
1229# to.
1230#
1231##############################################################################
1232
1233
1234
1235sub set_label_value($$)
1236{
1237
1238 my($widget, $value) = @_;
1239
1240 $widget->set_text($value);
1241 $tooltips->set_tip($widget->parent(), $value);
1242
1243}
1244#
1245##############################################################################
1246#
1247# Routine - glade_signal_autoconnect
1248#
1249# Description - This routine uses the Glade library to connect up all the
1250# registered signal handlers to their related widgets.
1251#
1252# Data - $glade : The Glade object describing the widgets that
1253# are to have their signal handlers
1254# registered.
1255# $client_data : The client data that is to be passed into
1256# each callback routine when it is called.
1257#
1258##############################################################################
1259
1260
1261
1262sub glade_signal_autoconnect($$)
1263{
1264
1265 my($glade, $client_data) = @_;
1266
1267 my $caller_package = caller();
1268 $caller_package = "main" if (! defined($caller_package));
1269
1270 $glade->signal_autoconnect
1271(sub {
1272 my($callback_name, $widget, $signal_name, $signal_data,
1273$connect_object, $after, $user_data) = @_;
1274 my $func = $after ? "signal_connect_after" : "signal_connect";
1275
1276 # Need to fully qualify any callback name that isn't prefixed by
1277 # it's package name with the name of the calling package.
1278
1279 $callback_name = $caller_package . "::" . $callback_name
1280 if (index($callback_name, "::") < 0);
1281
1282 # Actually connect the signal handler.
1283
1284 $widget->$func($signal_name,
1285 $callback_name,
1286 $connect_object ? $connect_object : $user_data);
1287 },
1288 $client_data);
1289
1290}
1291
12921;

Archive Download this file

Branches

Tags

Quick Links:     www.monotone.ca    -     Downloads    -     Documentation    -     Wiki    -     Code Forge    -     Build Status