| 1 |
package Hal::Cdroms; |
| 2 |
|
| 3 |
our $VERSION = 0.03; |
| 4 |
|
| 5 |
# Copyright (C) 2008 Mandriva |
| 6 |
# |
| 7 |
# This program is free software; You can redistribute it and/or modify |
| 8 |
# it under the same terms as Perl itself. Either: |
| 9 |
# |
| 10 |
# a) the GNU General Public License as published by the Free |
| 11 |
# Software Foundation; either version 2, or (at your option) any |
| 12 |
# later version, |
| 13 |
# |
| 14 |
# or |
| 15 |
# |
| 16 |
# b) the "Artistic License" |
| 17 |
# |
| 18 |
# The file "COPYING" distributed along with this file provides full |
| 19 |
# details of the terms and conditions of the two licenses. |
| 20 |
|
| 21 |
=head1 NAME |
| 22 |
|
| 23 |
Hal::Cdroms - access cdroms through HAL and D-Bus |
| 24 |
|
| 25 |
=head1 SYNOPSIS |
| 26 |
|
| 27 |
use Hal::Cdroms; |
| 28 |
|
| 29 |
my $hal_cdroms = Hal::Cdroms->new; |
| 30 |
|
| 31 |
foreach my $hal_path ($hal_cdroms->list) { |
| 32 |
my $m = $hal_cdroms->get_mount_point($hal_path); |
| 33 |
print "$hal_path ", $m ? "is mounted in $m" : "is not mounted", "\n"; |
| 34 |
} |
| 35 |
|
| 36 |
my $hal_path = $hal_cdroms->wait_for_insert; |
| 37 |
my $m = $hal_cdroms->mount($hal_path); |
| 38 |
print "$hal_path is now mounted in $m\n"; |
| 39 |
|
| 40 |
=head1 DESCRIPTION |
| 41 |
|
| 42 |
Access cdroms through HAL and D-Bus. |
| 43 |
|
| 44 |
=cut |
| 45 |
|
| 46 |
# internal constant |
| 47 |
my $hal_dn = 'org.freedesktop.UDisks'; |
| 48 |
|
| 49 |
|
| 50 |
=head2 Hal::Cdroms->new |
| 51 |
|
| 52 |
Creates the object |
| 53 |
|
| 54 |
=cut |
| 55 |
|
| 56 |
sub new { |
| 57 |
my ($class) = @_; |
| 58 |
|
| 59 |
require Net::DBus; |
| 60 |
require Net::DBus::Reactor; # must be done before line below: |
| 61 |
my $dbus = Net::DBus->system; |
| 62 |
my $hal = $dbus->get_service($hal_dn); |
| 63 |
|
| 64 |
bless { dbus => $dbus, hal => $hal }, $class; |
| 65 |
} |
| 66 |
|
| 67 |
=head2 $hal_cdroms->list |
| 68 |
|
| 69 |
Returns the list of C<hal_path> of the cdroms (mounted or not). |
| 70 |
|
| 71 |
=cut |
| 72 |
|
| 73 |
sub list { |
| 74 |
my ($o) = @_; |
| 75 |
|
| 76 |
my $manager = $o->{hal}->get_object("/org/freedesktop/UDisks", |
| 77 |
$hal_dn); |
| 78 |
|
| 79 |
@{$manager->FindDeviceByCapability('volume.disc')}; |
| 80 |
} |
| 81 |
|
| 82 |
=head2 $hal_cdroms->get_mount_point($hal_path) |
| 83 |
|
| 84 |
Return the mount point associated to the C<hal_path>, or undef it is not mounted. |
| 85 |
|
| 86 |
=cut |
| 87 |
|
| 88 |
sub _get_device { |
| 89 |
my ($o, $hal_path) = @_; |
| 90 |
$o->{hal}->get_object($hal_path, "$hal_dn.Device"); |
| 91 |
} |
| 92 |
sub _get_volume { |
| 93 |
my ($o, $hal_path) = @_; |
| 94 |
$o->{hal}->get_object($hal_path, "$hal_dn.Device.Volume"); |
| 95 |
} |
| 96 |
|
| 97 |
sub _GetProperty { |
| 98 |
my ($device, $pname) = @_; |
| 99 |
$device->Get('org.freedesktop.DBus.Properties', $pname); |
| 100 |
} |
| 101 |
|
| 102 |
sub get_mount_point { |
| 103 |
my ($o, $hal_path) = @_; |
| 104 |
|
| 105 |
my $device = _get_device($o, $hal_path); |
| 106 |
eval { $device->GetProperty('volume.is_mounted') |
| 107 |
&& $device->GetProperty('volume.mount_point') }; |
| 108 |
} |
| 109 |
|
| 110 |
sub _try { |
| 111 |
my ($o, $f) = @_; |
| 112 |
|
| 113 |
if (eval { $f->(); 1 }) { |
| 114 |
1; |
| 115 |
} else { |
| 116 |
$o->{error} = $@; |
| 117 |
undef; |
| 118 |
} |
| 119 |
} |
| 120 |
|
| 121 |
=head2 $hal_cdroms->ensure_mounted($hal_path) |
| 122 |
|
| 123 |
Mount the C<hal_path> if not already mounted. |
| 124 |
Return the mount point associated to the C<hal_path>, or undef it cannot be mounted successfully (see $hal_cdroms->{error}). |
| 125 |
|
| 126 |
=cut |
| 127 |
|
| 128 |
sub ensure_mounted { |
| 129 |
my ($o, $hal_path) = @_; |
| 130 |
|
| 131 |
$o->get_mount_point($hal_path) # check if it is already mounted |
| 132 |
|| $o->mount($hal_path) # otherwise try to mount |
| 133 |
|| $o->get_mount_point($hal_path); # checking wether a volume manager did it for us |
| 134 |
} |
| 135 |
|
| 136 |
|
| 137 |
=head2 $hal_cdroms->mount_through_hal($hal_path) |
| 138 |
|
| 139 |
Mount the C<hal_path> through HAL |
| 140 |
Return the mount point associated to the C<hal_path>, or undef it cannot be mounted successfully (see $hal_cdroms->{error}). |
| 141 |
If the cdrom is listed in fstab, HAL will refuse to mount it. |
| 142 |
|
| 143 |
=cut |
| 144 |
|
| 145 |
sub mount_hal { |
| 146 |
my ($o, $hal_path) = @_; |
| 147 |
|
| 148 |
my $device = _get_device($o, $hal_path); |
| 149 |
my $volume = _get_volume($o, $hal_path); |
| 150 |
|
| 151 |
my $fstype = $device->GetProperty('volume.fstype'); |
| 152 |
|
| 153 |
_try($o, sub { $volume->Mount("", $fstype, []) }) or return; |
| 154 |
|
| 155 |
eval { $device->GetProperty('volume.mount_point') }; |
| 156 |
} |
| 157 |
|
| 158 |
=head2 $hal_cdroms->mount($hal_path) |
| 159 |
|
| 160 |
Mount the C<hal_path> through HAL or fallback to plain mount(8). |
| 161 |
Return the mount point associated to the C<hal_path>, or undef it cannot be mounted successfully (see $hal_cdroms->{error}) |
| 162 |
|
| 163 |
=cut |
| 164 |
|
| 165 |
sub mount { |
| 166 |
my ($o, $hal_path) = @_; |
| 167 |
|
| 168 |
my $mntpoint = mount_hal($o, $hal_path); |
| 169 |
if (!$mntpoint) { |
| 170 |
# this usually means HAL refused to mount a cdrom listed in fstab |
| 171 |
my $dev = _get_device($o, $hal_path)->GetProperty('block.device'); |
| 172 |
if (my $wanted = $dev && _rdev($dev)) { |
| 173 |
my ($fstab_dev) = grep { $wanted == _rdev($_) } _fstab_devices(); |
| 174 |
system("mount", $fstab_dev) == 0 |
| 175 |
and $mntpoint = get_mount_point($o, $hal_path); |
| 176 |
} |
| 177 |
} |
| 178 |
$mntpoint; |
| 179 |
} |
| 180 |
|
| 181 |
sub _rdev { |
| 182 |
my ($dev) = @_; |
| 183 |
(stat($dev))[6]; |
| 184 |
} |
| 185 |
sub _fstab_devices() { |
| 186 |
open(my $F, '<', '/etc/fstab') or return; |
| 187 |
map { /(\S+)/ } <$F>; |
| 188 |
} |
| 189 |
|
| 190 |
=head2 $hal_cdroms->unmount($hal_path) |
| 191 |
|
| 192 |
Unmount the C<hal_path>. Return true on success (see $hal_cdroms->{error} on failure) |
| 193 |
If the cdrom is listed in not mounted by HAL, HAL will refuse to unmount it. |
| 194 |
|
| 195 |
=cut |
| 196 |
|
| 197 |
sub unmount_hal { |
| 198 |
my ($o, $hal_path) = @_; |
| 199 |
|
| 200 |
my $volume = _get_volume($o, $hal_path); |
| 201 |
_try($o, sub { $volume->Unmount([]) }); |
| 202 |
} |
| 203 |
|
| 204 |
=head2 $hal_cdroms->unmount($hal_path) |
| 205 |
|
| 206 |
Unmount the C<hal_path> through HAL or fallback on umount(8). |
| 207 |
Return true on success (see $hal_cdroms->{error} on failure) |
| 208 |
|
| 209 |
=cut |
| 210 |
|
| 211 |
sub unmount { |
| 212 |
my ($o, $hal_path) = @_; |
| 213 |
|
| 214 |
unmount_hal($o, $hal_path) and return 1; |
| 215 |
|
| 216 |
system('umount', get_mount_point($o, $hal_path)) == 0; |
| 217 |
} |
| 218 |
|
| 219 |
=head2 $hal_cdroms->eject($hal_path) |
| 220 |
|
| 221 |
Ejects the C<hal_path>. Return true on success (see $hal_cdroms->{error} on failure) |
| 222 |
|
| 223 |
=cut |
| 224 |
|
| 225 |
sub eject { |
| 226 |
my ($o, $hal_path) = @_; |
| 227 |
|
| 228 |
my $volume = _get_volume($o, $hal_path); |
| 229 |
_try($o, sub { $volume->Eject([]) }); |
| 230 |
} |
| 231 |
|
| 232 |
=head2 $hal_cdroms->wait_for_insert([$timeout]) |
| 233 |
|
| 234 |
Waits until a cdrom is inserted. |
| 235 |
Returns the inserted C<hal_path> on success. Otherwise returns undef. |
| 236 |
|
| 237 |
You can give an optional timeout in milliseconds. |
| 238 |
|
| 239 |
=cut |
| 240 |
|
| 241 |
sub wait_for_insert { |
| 242 |
my ($o, $o_timeout) = @_; |
| 243 |
|
| 244 |
_reactor_wait($o->{dbus}, $hal_dn, $o_timeout, sub { |
| 245 |
my ($msg) = @_; |
| 246 |
$msg->get_member eq 'DeviceAdded' && ($msg->get_args_list)[0]; |
| 247 |
}); |
| 248 |
} |
| 249 |
|
| 250 |
=head2 $hal_cdroms->wait_for_mounted([$timeout]) |
| 251 |
|
| 252 |
Waits until a cdrom is inserted and mounted by a volume manager (eg: gnome-volume-manager). |
| 253 |
Returns the mounted C<hal_path> on success. Otherwise returns undef. |
| 254 |
|
| 255 |
You can give an optional timeout in milliseconds. |
| 256 |
|
| 257 |
=cut |
| 258 |
|
| 259 |
sub wait_for_mounted { |
| 260 |
my ($o, $o_timeout) = @_; |
| 261 |
|
| 262 |
_reactor_wait($o->{dbus}, $hal_dn, $o_timeout, sub { |
| 263 |
my ($msg) = @_; |
| 264 |
$msg->get_member eq 'PropertyModified' or return; |
| 265 |
|
| 266 |
my (undef, $modified_properties) = $msg->get_args_list; |
| 267 |
grep { $_->[0] eq 'volume.is_mounted' } @$modified_properties or return; |
| 268 |
|
| 269 |
my $hal_path = $msg->get_path; |
| 270 |
my $device = _get_device($o, $hal_path); |
| 271 |
|
| 272 |
eval { $device->QueryCapability('volume.disc') && |
| 273 |
$device->GetProperty('volume.is_mounted') } && $hal_path; |
| 274 |
}); |
| 275 |
} |
| 276 |
|
| 277 |
sub _reactor_wait { |
| 278 |
my ($dbus, $interface, $timeout, $check_found) = @_; |
| 279 |
|
| 280 |
my $val; |
| 281 |
my $reactor = Net::DBus::Reactor->main; |
| 282 |
|
| 283 |
my $con = $dbus->get_connection; |
| 284 |
$con->add_match("type='signal',interface='$interface'"); |
| 285 |
$con->add_filter(sub { |
| 286 |
my ($_con, $msg) = @_; |
| 287 |
|
| 288 |
if ($val = $check_found->($msg)) { |
| 289 |
_reactor_shutdown($reactor); |
| 290 |
} |
| 291 |
}); |
| 292 |
if ($timeout) { |
| 293 |
$reactor->add_timeout($timeout, Net::DBus::Callback->new(method => sub { |
| 294 |
_reactor_shutdown($reactor); |
| 295 |
})); |
| 296 |
} |
| 297 |
$reactor->run; |
| 298 |
|
| 299 |
$val; |
| 300 |
} |
| 301 |
|
| 302 |
sub _reactor_shutdown { |
| 303 |
my ($reactor) = @_; |
| 304 |
|
| 305 |
$reactor->shutdown; |
| 306 |
|
| 307 |
# ugly, but needed for shutdown to work... |
| 308 |
$reactor->add_timeout(1, Net::DBus::Callback->new(method => sub {})); |
| 309 |
} |
| 310 |
|
| 311 |
sub member { my $e = shift; foreach (@_) { $e eq $_ and return 1 } 0 } |
| 312 |
|
| 313 |
=head1 AUTHOR |
| 314 |
|
| 315 |
Pascal Rigaux <pixel@mandriva.com> |
| 316 |
|
| 317 |
=cut |
Parent Directory
| 
Revision Log