File: OverwritePrompt.pm

package info (click to toggle)
libdemeter-perl 0.9.27%2Bds6-9
  • links: PTS, VCS
  • area: contrib
  • in suites: forky, sid, trixie
  • size: 74,028 kB
  • sloc: perl: 73,233; python: 2,196; makefile: 1,999; ansic: 1,368; lisp: 454; sh: 74
file content (122 lines) | stat: -rw-r--r-- 3,739 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
package Demeter::UI::Wx::OverwritePrompt;

=for Copyright
 .
 Copyright (c) 2006-2019 Bruce Ravel (http://bruceravel.github.io/home).
 All rights reserved.
 .
 This file is free software; you can redistribute it and/or
 modify it under the same terms as Perl itself. See The Perl
 Artistic License.
 .
 This program is distributed in the hope that it will be useful,
 but WITHOUT ANY WARRANTY; without even the implied warranty of
 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

=cut

use strict;
use warnings;
use Carp;
use Wx qw( :everything );
use base qw( Exporter );
our @EXPORT = qw(overwrite_prompt);

## return true if this file should not be overwritten
## return false if writing the file is ok (does not exists or can be overwritten)
sub overwrite_prompt {
  my ($self, $file, $frame) = @_;
  $frame ||= $self;
  return 0 if (not -e $file);
  my $yesno = Demeter::UI::Wx::VerbDialog->new($self, -1,
					       "Overwrite existing file \"$file\"?",
					       "Overwrite file?",
					       "Overwrite"
					      ); ##Wx::GetMousePosition --  how is this done?
  my $ok = $yesno->ShowModal;
  if ($ok == wxID_NO) {
    $frame->status("Not overwriting \"$file\"");
    return 1;
  };
  return 0;
};

1;

=head1 NAME

Demeter::UI::Wx::OverwritePrompt - A prompt dialog for overwriting a file

=head1 VERSION

This documentation refers to Demeter version 0.9.26.

=head1 SYNOPSIS

After querying the user for a file using Wx::FileDialog:

  my $file = $fd->GetPath;
  return if $frame->overwrite_prompt($file);

The calling object should be a Wx::Frame in Athena or Artemis.  Those
two programs add some functionality, including this, to Wx::Frame.

If that frame does not have its own statusbar, then you must specify a
second frame which does have a statusbar in which to display any
status messages:

  my $file = $fd->GetPath;
  return if $frame->overwrite_prompt($file, $other_frame);

This is not a general purpose tool.  It has hardwired aspects that
rely upon coding conventions used in Athena and Artemis.

=head1 DESCRIPTION

The exports a method that posts a prompt about whether to overwrite a
file that exists.  It returns true if the user does not want to
overwrite and returns false either if the file is to be overwritten or
if the file does not already exist.

This should not be necessary.  It is an inelegant alternative to
specifying the C<wxFD_OVERWRITE_PROMPT> style for Wx::FileDialog.
However there exists a bug in gtk 2.20 (is that right? others?) that
leads to serious misbehaviour in certain situations.  Using that
style, it is possible to have Wx::FileDialog return the wrong file,
resulting in the incorrect file being overwritten.

Here is more information:
L<https://bugzilla.gnome.org/show_bug.cgi?id=631908> and
L<https://bugs.launchpad.net/ubuntu/+source/gtk+2.0/+bug/558674>.

Until this bug is fixed at the level of gtk, the
C<wxFD_OVERWRITE_PROMPT> style cannot be safely used.

This is unused in 0.9.20.  I am assuming that no one is still using
gtk 2.20.  Fingers crossed....

=head1 BUGS AND LIMITATIONS

Please report problems to the Ifeffit Mailing List
(L<http://cars9.uchicago.edu/mailman/listinfo/ifeffit/>)

Patches are welcome.

=head1 AUTHOR

Bruce Ravel (L<http://bruceravel.github.io/home>)

L<http://bruceravel.github.io/demeter/>

=head1 LICENCE AND COPYRIGHT

Copyright (c) 2006-2019 Bruce Ravel (L<http://bruceravel.github.io/home>). All rights reserved.

This module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself. See L<perlgpl>.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

=cut