├── .github └── FUNDING.yml ├── README.md └── dd-gui.app └── Contents ├── Info.plist ├── MacOS ├── Pashua ├── Pashua.pm ├── bar ├── dd.command ├── ddgui └── dev.php ├── PkgInfo └── Resources ├── English.lproj ├── InfoPlist.strings ├── MainMenu.nib │ ├── classes.nib │ ├── info.nib │ └── keyedobjects.nib └── dict.strings ├── French.lproj ├── MainMenu.nib │ ├── classes.nib │ ├── info.nib │ └── keyedobjects.nib └── dict.strings └── German.lproj ├── MainMenu.nib ├── classes.nib ├── info.nib └── keyedobjects.nib └── dict.strings /.github/FUNDING.yml: -------------------------------------------------------------------------------- 1 | # These are supported funding model platforms 2 | 3 | patreon: gingerbeardman 4 | ko_fi: gingerbeardman 5 | custom: https://www.paypal.me/mattsephton 6 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | dd-gui 2 | ====== 3 | 4 | ## Background 5 | dd is a command line tool to do byte-exact copy. 6 | 7 | ## Purpose 8 | dd-gui is a simple GUI wrapper to enable you to easily launch dd without resorting to the command line. It will also show progress information throughout the copy. 9 | 10 | ## Usage 11 | Both source and destination can be either a system device from /dev or a file with the extension .img, for example: /dev/disk4, /files/dd.img 12 | 13 | The app has only been tested on Mac OS 10.6.x 14 | 15 | ## **Warning** 16 | **If you choose the wrong device as the destination, you can erase important data! Proceed with caution.** 17 | 18 | ## Changelog 19 | 2013-11-04: Added sudo to fix permissions issue on Mac OS 10.9 Mavericks (0.22) 20 | 2009-09-17: Added option to list devices (0.21) 21 | 2009-09-16: Added automatic unmounting and mounting of devices, plus more robust determination of source size (0.20) 22 | 2009-09-07: Initial release (0.10) 23 | 24 | ## Future versions 25 | I may add support for all dd features, just like [Air Imager](http://air-imager.sourceforge.net/) on Linux. 26 | 27 | ## Links 28 | [man dd](http://www.freebsd.org/cgi/man.cgi?query=dd&sektion=1) information on the dd command 29 | 30 | ## License 31 | 32 | dd-gui is made available under a [Creative Commons Attribution-Share Alike 3.0 Unported License](http://creativecommons.org/licenses/by-sa/3.0). 33 | -------------------------------------------------------------------------------- /dd-gui.app/Contents/Info.plist: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | CFBundleDevelopmentRegion 6 | English 7 | CFBundleExecutable 8 | ddgui 9 | CFBundleIconFile 10 | AppIcon 11 | CFBundleInfoDictionaryVersion 12 | 6.0 13 | CFBundleName 14 | ddgui 15 | CFBundlePackageType 16 | APPL 17 | CFBundleSignature 18 | ???? 19 | CFBundleVersion 20 | 0.22 21 | LSUIElement 22 | 23 | NSMainNibFile 24 | MainMenu 25 | NSPrincipalClass 26 | NSApplication 27 | 28 | 29 | -------------------------------------------------------------------------------- /dd-gui.app/Contents/MacOS/Pashua: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gingerbeardman/dd-gui/5ee8d18b017a0b51fb40101dac13f395aa96b79b/dd-gui.app/Contents/MacOS/Pashua -------------------------------------------------------------------------------- /dd-gui.app/Contents/MacOS/Pashua.pm: -------------------------------------------------------------------------------- 1 | package Pashua; 2 | 3 | =head1 NAME 4 | 5 | Pashua - Interface to Pashua.app 6 | 7 | =head1 SYNOPSIS 8 | 9 | use Pashua; 10 | 11 | # Set transparency: 0 is transparent, 1 is opaque 12 | transparency=0.95 13 | 14 | # Set window title 15 | title = Introducing Pashua 16 | 17 | # Introductory text 18 | tb.label = About Pashua 19 | tb.type = textbox 20 | tb.default = Pashua is an application for generating dialog windows from programming languages (in this case: Perl) which lack support for creating native GUIs on Mac OS X. Any information you enter in this example window will be returned to the calling script when you hit "OK"; if you decide to click "Cancel" or press "Esc" instead, no values will be returned.[return][return]This window demonstrates about half of the GUI widgets that are available in Pashua. You can find a full list of all GUI elements and their corresponding attributes in section "Table of element types and attributes" of Pashua's documentation (folder "Documentation" on this disk image). 21 | tb.height = 6 22 | tb.width = 380 23 | 24 | # Display Pashua's icon 25 | img.type = image 26 | img.label = This is Pashua's icon 27 | img.path = /Volumes/Pashua/Pashua.app/Contents/Resources/Pashua.icns 28 | 29 | # Add a text field 30 | tx.type = textfield 31 | tx.label = Example textfield 32 | tx.default = Textfield content 33 | tx.width = 380 34 | 35 | # Add a filesystem browser 36 | ob.type = openbrowser 37 | ob.label = Example filesystem browser (textfield + open panel) 38 | ob.width=380 39 | ob.tooltip = Blabla filesystem browser 40 | 41 | # Define radiobuttons 42 | rb.type = radiobutton 43 | rb.label = Example radiobuttons 44 | rb.option = Radiobutton item #1 45 | rb.option = Radiobutton item #2 46 | rb.default = Radiobutton item #1 47 | 48 | # Add a popup menu 49 | pop.type = popup 50 | pop.label = Example popup menu 51 | pop.width = 380 52 | pop.option = Popup menu item #1 53 | pop.option = Popup menu item #2 54 | pop.option = Popup menu item #3 55 | pop.default = Popup menu item #2 56 | 57 | # Add a cancel button with default label 58 | cb.type=cancelbutton 59 | 60 | # A default button is added automatically - if you want to 61 | # change the button title, you should uncomment the next 62 | # two lines to override the "built-in" default button 63 | #db.type=defaultbutton 64 | #db.label=Click here to return the values 65 | 66 | EOCONF 67 | 68 | # ... and save the result in %result 69 | my %result = Pashua::run($var); 70 | 71 | =head1 DESCRIPTION 72 | 73 | Pashua is an application that can be used to provide dialog GUIs 74 | for (among other languages) Perl applications under Mac OS X. 75 | Pashua.pm is the glue between your scripty and Pashua. To learn 76 | more about Pashua, take a look at the application's Readme file. 77 | 78 | The Perl code that comes with Pashua (example script and this module, 79 | Pashua.pm) is only a suggestion and you are free to write your own code. 80 | For instance, the Perl code is in no way "idiomatic", and maybe you'd 81 | prefer some sort of OOP approach. It's up to you :-) 82 | 83 | =head1 EXAMPLES 84 | 85 | Many GUI elements that are available are demonstrated in the example 86 | above, so there's mot much more to show ;-) To learn more about the 87 | configuration syntax, take a look at the documentation which is 88 | included with Pashua. 89 | 90 | Please note in order for the example to work, the Pashua application 91 | must be in the current path, in the calling script's path, in 92 | /Applications/ or in ~/Applications/ 93 | If none of these paths apply, you will have to specify it manually: 94 | $Pashua::PATH = '/path/to/appfolder'; 95 | before you call Pashua::run(). You can also create a symlink (a symlink, 96 | NOT a Mac OS X Finder alias) to Pashua in one of the directories 97 | mentioned above. As an alternative, you can supply Pashua.app's path 98 | as 3rd argument to sub run. 99 | 100 | =head1 AUTHOR / TERMS AND CONDITIONS 101 | 102 | Pashua and this Perl module are copyright (c) 2003-2005 Carsten Bluem, 103 | . You can use and /or modify this module in any way 104 | you like. For information on the Pashua license (which is not 105 | necessarily the same as this module's license) see Pashua's Readme file. 106 | Pashua can be found on http://www.bluem.net/downloads/pashua_en/ 107 | 108 | This software comes with NO WARRANTY of any kind. 109 | 110 | =cut 111 | 112 | 113 | require 5.005; 114 | 115 | use File::Basename; 116 | use vars qw($VERSION $PATH); 117 | 118 | $VERSION = '0.9.3'; 119 | $PATH = ''; 120 | 121 | 122 | # Pashua::run - Calls the pashua binary, parses its result string 123 | # and generates a Perl hash that's returned. Attention: This sub 124 | # uses the module File::Temp, which is included with OSX 10.3's 125 | # Perl, but not with OS versions prior to 10.3. For convenience 126 | # reasons, I have copied the File::Basename code into this file. 127 | # If you are running 10.3 or later, you can remove this part and 128 | # simply use the line use File::Temp qw(tempfile) above. 129 | # Argument 1: Configuration (dialog description) string 130 | # Argument 2 (optional): Config. string text encoding, see documentation 131 | # Argument 3 (optional): Directory that contains Pashua 132 | sub run { 133 | 134 | # Initialize variables 135 | my ($fh, $configfile, $path, $result, $arguments); 136 | 137 | # Get name and handle to temporary file 138 | ($fh, $configfile) = File::Temp::tempfile(UNLINK => 1); 139 | 140 | # Get function arguments 141 | my($confstring, $encoding, $appdir) = (shift, shift, shift); 142 | 143 | # Write data to temporary file 144 | print $fh $confstring; 145 | close $fh or die "Error trying to close $configfile: $!"; 146 | 147 | # Try to figure out the path to pashua 148 | my $bundlepath = "Pashua.app/Contents/MacOS/Pashua"; 149 | 150 | # Set the paths where to search for Pashua 151 | my @searchpaths = ( 152 | dirname($0)."/Pashua", 153 | dirname($0)."/$bundlepath", 154 | "$PATH/$bundlepath", 155 | "./$bundlepath", 156 | "/Applications/$bundlepath", 157 | "$ENV{HOME}/Applications/$bundlepath" 158 | ); 159 | 160 | # Use the directory given as argument 161 | if (defined $appdir) { 162 | if (!-d $appdir or !-e "$appdir/$bundlepath") { 163 | die ("The path $appdir/$bundlepath is invalid"); 164 | } 165 | unshift(@searchpaths, "$appdir/$bundlepath"); 166 | } 167 | 168 | # Search for the Pashua binary 169 | foreach (@searchpaths) { 170 | next unless -e; 171 | next unless -x; 172 | $path = $_; 173 | last; 174 | } 175 | 176 | die "Unable to locate the Pashua application.\n" unless $path; 177 | 178 | # Pass encoding as argument to Pashua 179 | if (defined $encoding and $encoding =~ m/^\w+$/) { 180 | $arguments = "-e $encoding "; 181 | } 182 | else { 183 | $arguments = ""; 184 | } 185 | 186 | # Call pashua binary with config file as argument and read result 187 | $cmd = "'$path' $arguments $configfile"; 188 | $result = `$cmd`; 189 | 190 | # Parse result 191 | my %result = (); 192 | foreach (split/\n/, $result) { 193 | /^(\w+)=(.*)$/; 194 | next unless defined $1; 195 | $result{$1} = $2; 196 | } 197 | 198 | # Return resulting hash 199 | return %result; 200 | 201 | } # sub run 202 | 203 | 204 | 205 | 206 | 207 | ############################ File/Temp.pl module ######################### 208 | # Included for convenience reasons, as it is not part of Mac OS X < 10.3 # 209 | ########################################################################## 210 | 211 | package File::Temp; 212 | 213 | =head1 NAME 214 | 215 | File::Temp - return name and handle of a temporary file safely 216 | 217 | =begin __INTERNALS 218 | 219 | =head1 PORTABILITY 220 | 221 | This module is designed to be portable across operating systems 222 | and it currently supports Unix, VMS, DOS, OS/2, Windows and 223 | Mac OS (Classic). When 224 | porting to a new OS there are generally three main issues 225 | that have to be solved: 226 | 227 | =over 4 228 | 229 | =item * 230 | 231 | Can the OS unlink an open file? If it can not then the 232 | C<_can_unlink_opened_file> method should be modified. 233 | 234 | =item * 235 | 236 | Are the return values from C reliable? By default all the 237 | return values from C are compared when unlinking a temporary 238 | file using the filename and the handle. Operating systems other than 239 | unix do not always have valid entries in all fields. If C fails 240 | then the C comparison should be modified accordingly. 241 | 242 | =item * 243 | 244 | Security. Systems that can not support a test for the sticky bit 245 | on a directory can not use the MEDIUM and HIGH security tests. 246 | The C<_can_do_level> method should be modified accordingly. 247 | 248 | =back 249 | 250 | =end __INTERNALS 251 | 252 | =head1 SYNOPSIS 253 | 254 | use File::Temp qw/ tempfile tempdir /; 255 | 256 | $dir = tempdir( CLEANUP => 1 ); 257 | ($fh, $filename) = tempfile( DIR => $dir ); 258 | 259 | ($fh, $filename) = tempfile( $template, DIR => $dir); 260 | ($fh, $filename) = tempfile( $template, SUFFIX => '.dat'); 261 | 262 | $fh = tempfile(); 263 | 264 | MkTemp family: 265 | 266 | use File::Temp qw/ :mktemp /; 267 | 268 | ($fh, $file) = mkstemp( "tmpfileXXXXX" ); 269 | ($fh, $file) = mkstemps( "tmpfileXXXXXX", $suffix); 270 | 271 | $tmpdir = mkdtemp( $template ); 272 | 273 | $unopened_file = mktemp( $template ); 274 | 275 | POSIX functions: 276 | 277 | use File::Temp qw/ :POSIX /; 278 | 279 | $file = tmpnam(); 280 | $fh = tmpfile(); 281 | 282 | ($fh, $file) = tmpnam(); 283 | $fh = tmpfile(); 284 | 285 | 286 | Compatibility functions: 287 | 288 | $unopened_file = File::Temp::tempnam( $dir, $pfx ); 289 | 290 | =begin later 291 | 292 | Objects (NOT YET IMPLEMENTED): 293 | 294 | require File::Temp; 295 | 296 | $fh = new File::Temp($template); 297 | $fname = $fh->filename; 298 | 299 | =end later 300 | 301 | =head1 DESCRIPTION 302 | 303 | C can be used to create and open temporary files in a safe way. 304 | The tempfile() function can be used to return the name and the open 305 | filehandle of a temporary file. The tempdir() function can 306 | be used to create a temporary directory. 307 | 308 | The security aspect of temporary file creation is emphasized such that 309 | a filehandle and filename are returned together. This helps guarantee 310 | that a race condition can not occur where the temporary file is 311 | created by another process between checking for the existence of the 312 | file and its opening. Additional security levels are provided to 313 | check, for example, that the sticky bit is set on world writable 314 | directories. See L<"safe_level"> for more information. 315 | 316 | For compatibility with popular C library functions, Perl implementations of 317 | the mkstemp() family of functions are provided. These are, mkstemp(), 318 | mkstemps(), mkdtemp() and mktemp(). 319 | 320 | Additionally, implementations of the standard L 321 | tmpnam() and tmpfile() functions are provided if required. 322 | 323 | Implementations of mktemp(), tmpnam(), and tempnam() are provided, 324 | but should be used with caution since they return only a filename 325 | that was valid when function was called, so cannot guarantee 326 | that the file will not exist by the time the caller opens the filename. 327 | 328 | =cut 329 | 330 | # 5.6.0 gives us S_IWOTH, S_IWGRP, our and auto-vivifying filehandls 331 | # People would like a version on 5.005 so give them what they want :-) 332 | use 5.005; 333 | use strict; 334 | use Carp; 335 | use File::Spec 0.8; 336 | use File::Path qw/ rmtree /; 337 | use Fcntl 1.03; 338 | use Errno; 339 | require VMS::Stdio if $^O eq 'VMS'; 340 | 341 | # Need the Symbol package if we are running older perl 342 | require Symbol if $] < 5.006; 343 | 344 | 345 | # use 'our' on v5.6.0 346 | use vars qw($VERSION @EXPORT_OK %EXPORT_TAGS $DEBUG); 347 | 348 | $DEBUG = 0; 349 | 350 | # We are exporting functions 351 | 352 | use base qw/Exporter/; 353 | 354 | # Export list - to allow fine tuning of export table 355 | 356 | @EXPORT_OK = qw{ 357 | tempfile 358 | tempdir 359 | tmpnam 360 | tmpfile 361 | mktemp 362 | mkstemp 363 | mkstemps 364 | mkdtemp 365 | unlink0 366 | }; 367 | 368 | # Groups of functions for export 369 | 370 | %EXPORT_TAGS = ( 371 | 'POSIX' => [qw/ tmpnam tmpfile /], 372 | 'mktemp' => [qw/ mktemp mkstemp mkstemps mkdtemp/], 373 | ); 374 | 375 | # add contents of these tags to @EXPORT 376 | Exporter::export_tags('POSIX','mktemp'); 377 | 378 | # Version number 379 | 380 | $VERSION = '0.13'; 381 | 382 | # This is a list of characters that can be used in random filenames 383 | 384 | my @CHARS = (qw/ A B C D E F G H I J K L M N O P Q R S T U V W X Y Z 385 | a b c d e f g h i j k l m n o p q r s t u v w x y z 386 | 0 1 2 3 4 5 6 7 8 9 _ 387 | /); 388 | 389 | # Maximum number of tries to make a temp file before failing 390 | 391 | use constant MAX_TRIES => 10; 392 | 393 | # Minimum number of X characters that should be in a template 394 | use constant MINX => 4; 395 | 396 | # Default template when no template supplied 397 | 398 | use constant TEMPXXX => 'X' x 10; 399 | 400 | # Constants for the security level 401 | 402 | use constant STANDARD => 0; 403 | use constant MEDIUM => 1; 404 | use constant HIGH => 2; 405 | 406 | # OPENFLAGS. If we defined the flag to use with Sysopen here this gives 407 | # us an optimisation when many temporary files are requested 408 | 409 | my $OPENFLAGS = O_CREAT | O_EXCL | O_RDWR; 410 | 411 | unless ($^O eq 'MacOS') { 412 | for my $oflag (qw/ FOLLOW BINARY LARGEFILE EXLOCK NOINHERIT /) { 413 | my ($bit, $func) = (0, "Fcntl::O_" . $oflag); 414 | no strict 'refs'; 415 | $OPENFLAGS |= $bit if eval { 416 | # Make sure that redefined die handlers do not cause problems 417 | # eg CGI::Carp 418 | local $SIG{__DIE__} = sub {}; 419 | local $SIG{__WARN__} = sub {}; 420 | $bit = &$func(); 421 | 1; 422 | }; 423 | } 424 | } 425 | 426 | # On some systems the O_TEMPORARY flag can be used to tell the OS 427 | # to automatically remove the file when it is closed. This is fine 428 | # in most cases but not if tempfile is called with UNLINK=>0 and 429 | # the filename is requested -- in the case where the filename is to 430 | # be passed to another routine. This happens on windows. We overcome 431 | # this by using a second open flags variable 432 | 433 | my $OPENTEMPFLAGS = $OPENFLAGS; 434 | unless ($^O eq 'MacOS') { 435 | for my $oflag (qw/ TEMPORARY /) { 436 | my ($bit, $func) = (0, "Fcntl::O_" . $oflag); 437 | no strict 'refs'; 438 | $OPENTEMPFLAGS |= $bit if eval { 439 | # Make sure that redefined die handlers do not cause problems 440 | # eg CGI::Carp 441 | local $SIG{__DIE__} = sub {}; 442 | local $SIG{__WARN__} = sub {}; 443 | $bit = &$func(); 444 | 1; 445 | }; 446 | } 447 | } 448 | 449 | # INTERNAL ROUTINES - not to be used outside of package 450 | 451 | # Generic routine for getting a temporary filename 452 | # modelled on OpenBSD _gettemp() in mktemp.c 453 | 454 | # The template must contain X's that are to be replaced 455 | # with the random values 456 | 457 | # Arguments: 458 | 459 | # TEMPLATE - string containing the XXXXX's that is converted 460 | # to a random filename and opened if required 461 | 462 | # Optionally, a hash can also be supplied containing specific options 463 | # "open" => if true open the temp file, else just return the name 464 | # default is 0 465 | # "mkdir"=> if true, we are creating a temp directory rather than tempfile 466 | # default is 0 467 | # "suffixlen" => number of characters at end of PATH to be ignored. 468 | # default is 0. 469 | # "unlink_on_close" => indicates that, if possible, the OS should remove 470 | # the file as soon as it is closed. Usually indicates 471 | # use of the O_TEMPORARY flag to sysopen. 472 | # Usually irrelevant on unix 473 | 474 | # Optionally a reference to a scalar can be passed into the function 475 | # On error this will be used to store the reason for the error 476 | # "ErrStr" => \$errstr 477 | 478 | # "open" and "mkdir" can not both be true 479 | # "unlink_on_close" is not used when "mkdir" is true. 480 | 481 | # The default options are equivalent to mktemp(). 482 | 483 | # Returns: 484 | # filehandle - open file handle (if called with doopen=1, else undef) 485 | # temp name - name of the temp file or directory 486 | 487 | # For example: 488 | # ($fh, $name) = _gettemp($template, "open" => 1); 489 | 490 | # for the current version, failures are associated with 491 | # stored in an error string and returned to give the reason whilst debugging 492 | # This routine is not called by any external function 493 | sub _gettemp { 494 | 495 | croak 'Usage: ($fh, $name) = _gettemp($template, OPTIONS);' 496 | unless scalar(@_) >= 1; 497 | 498 | # the internal error string - expect it to be overridden 499 | # Need this in case the caller decides not to supply us a value 500 | # need an anonymous scalar 501 | my $tempErrStr; 502 | 503 | # Default options 504 | my %options = ( 505 | "open" => 0, 506 | "mkdir" => 0, 507 | "suffixlen" => 0, 508 | "unlink_on_close" => 0, 509 | "ErrStr" => \$tempErrStr, 510 | ); 511 | 512 | # Read the template 513 | my $template = shift; 514 | if (ref($template)) { 515 | # Use a warning here since we have not yet merged ErrStr 516 | carp "File::Temp::_gettemp: template must not be a reference"; 517 | return (); 518 | } 519 | 520 | # Check that the number of entries on stack are even 521 | if (scalar(@_) % 2 != 0) { 522 | # Use a warning here since we have not yet merged ErrStr 523 | carp "File::Temp::_gettemp: Must have even number of options"; 524 | return (); 525 | } 526 | 527 | # Read the options and merge with defaults 528 | %options = (%options, @_) if @_; 529 | 530 | # Make sure the error string is set to undef 531 | ${$options{ErrStr}} = undef; 532 | 533 | # Can not open the file and make a directory in a single call 534 | if ($options{"open"} && $options{"mkdir"}) { 535 | ${$options{ErrStr}} = "doopen and domkdir can not both be true\n"; 536 | return (); 537 | } 538 | 539 | # Find the start of the end of the Xs (position of last X) 540 | # Substr starts from 0 541 | my $start = length($template) - 1 - $options{"suffixlen"}; 542 | 543 | # Check that we have at least MINX x X (eg 'XXXX") at the end of the string 544 | # (taking suffixlen into account). Any fewer is insecure. 545 | 546 | # Do it using substr - no reason to use a pattern match since 547 | # we know where we are looking and what we are looking for 548 | 549 | if (substr($template, $start - MINX + 1, MINX) ne 'X' x MINX) { 550 | ${$options{ErrStr}} = "The template must contain at least ". 551 | MINX . " 'X' characters\n"; 552 | return (); 553 | } 554 | 555 | # Replace all the X at the end of the substring with a 556 | # random character or just all the XX at the end of a full string. 557 | # Do it as an if, since the suffix adjusts which section to replace 558 | # and suffixlen=0 returns nothing if used in the substr directly 559 | # and generate a full path from the template 560 | 561 | my $path = _replace_XX($template, $options{"suffixlen"}); 562 | 563 | 564 | # Split the path into constituent parts - eventually we need to check 565 | # whether the directory exists 566 | # We need to know whether we are making a temp directory 567 | # or a tempfile 568 | 569 | my ($volume, $directories, $file); 570 | my $parent; # parent directory 571 | if ($options{"mkdir"}) { 572 | # There is no filename at the end 573 | ($volume, $directories, $file) = File::Spec->splitpath( $path, 1); 574 | 575 | # The parent is then $directories without the last directory 576 | # Split the directory and put it back together again 577 | my @dirs = File::Spec->splitdir($directories); 578 | 579 | # If @dirs only has one entry (i.e. the directory template) that means 580 | # we are in the current directory 581 | if ($#dirs == 0) { 582 | $parent = File::Spec->curdir; 583 | } else { 584 | 585 | if ($^O eq 'VMS') { # need volume to avoid relative dir spec 586 | $parent = File::Spec->catdir($volume, @dirs[0..$#dirs-1]); 587 | $parent = 'sys$disk:[]' if $parent eq ''; 588 | } else { 589 | 590 | # Put it back together without the last one 591 | $parent = File::Spec->catdir(@dirs[0..$#dirs-1]); 592 | 593 | # ...and attach the volume (no filename) 594 | $parent = File::Spec->catpath($volume, $parent, ''); 595 | } 596 | 597 | } 598 | 599 | } else { 600 | 601 | # Get rid of the last filename (use File::Basename for this?) 602 | ($volume, $directories, $file) = File::Spec->splitpath( $path ); 603 | 604 | # Join up without the file part 605 | $parent = File::Spec->catpath($volume,$directories,''); 606 | 607 | # If $parent is empty replace with curdir 608 | $parent = File::Spec->curdir 609 | unless $directories ne ''; 610 | 611 | } 612 | 613 | # Check that the parent directories exist 614 | # Do this even for the case where we are simply returning a name 615 | # not a file -- no point returning a name that includes a directory 616 | # that does not exist or is not writable 617 | 618 | unless (-d $parent) { 619 | ${$options{ErrStr}} = "Parent directory ($parent) is not a directory"; 620 | return (); 621 | } 622 | unless (-w _) { 623 | ${$options{ErrStr}} = "Parent directory ($parent) is not writable\n"; 624 | return (); 625 | } 626 | 627 | 628 | # Check the stickiness of the directory and chown giveaway if required 629 | # If the directory is world writable the sticky bit 630 | # must be set 631 | 632 | if (File::Temp->safe_level == MEDIUM) { 633 | my $safeerr; 634 | unless (_is_safe($parent,\$safeerr)) { 635 | ${$options{ErrStr}} = "Parent directory ($parent) is not safe ($safeerr)"; 636 | return (); 637 | } 638 | } elsif (File::Temp->safe_level == HIGH) { 639 | my $safeerr; 640 | unless (_is_verysafe($parent, \$safeerr)) { 641 | ${$options{ErrStr}} = "Parent directory ($parent) is not safe ($safeerr)"; 642 | return (); 643 | } 644 | } 645 | 646 | 647 | # Now try MAX_TRIES time to open the file 648 | for (my $i = 0; $i < MAX_TRIES; $i++) { 649 | 650 | # Try to open the file if requested 651 | if ($options{"open"}) { 652 | my $fh; 653 | 654 | # If we are running before perl5.6.0 we can not auto-vivify 655 | if ($] < 5.006) { 656 | $fh = &Symbol::gensym; 657 | } 658 | 659 | # Try to make sure this will be marked close-on-exec 660 | # XXX: Win32 doesn't respect this, nor the proper fcntl, 661 | # but may have O_NOINHERIT. This may or may not be in Fcntl. 662 | local $^F = 2; 663 | 664 | # Store callers umask 665 | my $umask = umask(); 666 | 667 | # Set a known umask 668 | umask(066); 669 | 670 | # Attempt to open the file 671 | my $open_success = undef; 672 | if ( $^O eq 'VMS' and $options{"unlink_on_close"} ) { 673 | # make it auto delete on close by setting FAB$V_DLT bit 674 | $fh = VMS::Stdio::vmssysopen($path, $OPENFLAGS, 0600, 'fop=dlt'); 675 | $open_success = $fh; 676 | } else { 677 | my $flags = ( $options{"unlink_on_close"} ? 678 | $OPENTEMPFLAGS : 679 | $OPENFLAGS ); 680 | $open_success = sysopen($fh, $path, $flags, 0600); 681 | } 682 | if ( $open_success ) { 683 | 684 | # Reset umask 685 | umask($umask) if defined $umask; 686 | 687 | # Opened successfully - return file handle and name 688 | return ($fh, $path); 689 | 690 | } else { 691 | # Reset umask 692 | umask($umask) if defined $umask; 693 | 694 | # Error opening file - abort with error 695 | # if the reason was anything but EEXIST 696 | unless ($!{EEXIST}) { 697 | ${$options{ErrStr}} = "Could not create temp file $path: $!"; 698 | return (); 699 | } 700 | 701 | # Loop round for another try 702 | 703 | } 704 | } elsif ($options{"mkdir"}) { 705 | 706 | # Store callers umask 707 | my $umask = umask(); 708 | 709 | # Set a known umask 710 | umask(066); 711 | 712 | # Open the temp directory 713 | if (mkdir( $path, 0700)) { 714 | # created okay 715 | # Reset umask 716 | umask($umask) if defined $umask; 717 | 718 | return undef, $path; 719 | } else { 720 | 721 | # Reset umask 722 | umask($umask) if defined $umask; 723 | 724 | # Abort with error if the reason for failure was anything 725 | # except EEXIST 726 | unless ($!{EEXIST}) { 727 | ${$options{ErrStr}} = "Could not create directory $path: $!"; 728 | return (); 729 | } 730 | 731 | # Loop round for another try 732 | 733 | } 734 | 735 | } else { 736 | 737 | # Return true if the file can not be found 738 | # Directory has been checked previously 739 | 740 | return (undef, $path) unless -e $path; 741 | 742 | # Try again until MAX_TRIES 743 | 744 | } 745 | 746 | # Did not successfully open the tempfile/dir 747 | # so try again with a different set of random letters 748 | # No point in trying to increment unless we have only 749 | # 1 X say and the randomness could come up with the same 750 | # file MAX_TRIES in a row. 751 | 752 | # Store current attempt - in principal this implies that the 753 | # 3rd time around the open attempt that the first temp file 754 | # name could be generated again. Probably should store each 755 | # attempt and make sure that none are repeated 756 | 757 | my $original = $path; 758 | my $counter = 0; # Stop infinite loop 759 | my $MAX_GUESS = 50; 760 | 761 | do { 762 | 763 | # Generate new name from original template 764 | $path = _replace_XX($template, $options{"suffixlen"}); 765 | 766 | $counter++; 767 | 768 | } until ($path ne $original || $counter > $MAX_GUESS); 769 | 770 | # Check for out of control looping 771 | if ($counter > $MAX_GUESS) { 772 | ${$options{ErrStr}} = "Tried to get a new temp name different to the previous value $MAX_GUESS times.\nSomething wrong with template?? ($template)"; 773 | return (); 774 | } 775 | 776 | } 777 | 778 | # If we get here, we have run out of tries 779 | ${ $options{ErrStr} } = "Have exceeded the maximum number of attempts (" 780 | . MAX_TRIES . ") to open temp file/dir"; 781 | 782 | return (); 783 | 784 | } 785 | 786 | # Internal routine to return a random character from the 787 | # character list. Does not do an srand() since rand() 788 | # will do one automatically 789 | 790 | # No arguments. Return value is the random character 791 | 792 | # No longer called since _replace_XX runs a few percent faster if 793 | # I inline the code. This is important if we are creating thousands of 794 | # temporary files. 795 | 796 | sub _randchar { 797 | 798 | $CHARS[ int( rand( $#CHARS ) ) ]; 799 | 800 | } 801 | 802 | # Internal routine to replace the XXXX... with random characters 803 | # This has to be done by _gettemp() every time it fails to 804 | # open a temp file/dir 805 | 806 | # Arguments: $template (the template with XXX), 807 | # $ignore (number of characters at end to ignore) 808 | 809 | # Returns: modified template 810 | 811 | sub _replace_XX { 812 | 813 | croak 'Usage: _replace_XX($template, $ignore)' 814 | unless scalar(@_) == 2; 815 | 816 | my ($path, $ignore) = @_; 817 | 818 | # Do it as an if, since the suffix adjusts which section to replace 819 | # and suffixlen=0 returns nothing if used in the substr directly 820 | # Alternatively, could simply set $ignore to length($path)-1 821 | # Don't want to always use substr when not required though. 822 | 823 | if ($ignore) { 824 | substr($path, 0, - $ignore) =~ s/X(?=X*\z)/$CHARS[ int( rand( $#CHARS ) ) ]/ge; 825 | } else { 826 | $path =~ s/X(?=X*\z)/$CHARS[ int( rand( $#CHARS ) ) ]/ge; 827 | } 828 | 829 | return $path; 830 | } 831 | 832 | # internal routine to check to see if the directory is safe 833 | # First checks to see if the directory is not owned by the 834 | # current user or root. Then checks to see if anyone else 835 | # can write to the directory and if so, checks to see if 836 | # it has the sticky bit set 837 | 838 | # Will not work on systems that do not support sticky bit 839 | 840 | #Args: directory path to check 841 | # Optionally: reference to scalar to contain error message 842 | # Returns true if the path is safe and false otherwise. 843 | # Returns undef if can not even run stat() on the path 844 | 845 | # This routine based on version written by Tom Christiansen 846 | 847 | # Presumably, by the time we actually attempt to create the 848 | # file or directory in this directory, it may not be safe 849 | # anymore... Have to run _is_safe directly after the open. 850 | 851 | sub _is_safe { 852 | 853 | my $path = shift; 854 | my $err_ref = shift; 855 | 856 | # Stat path 857 | my @info = stat($path); 858 | unless (scalar(@info)) { 859 | $$err_ref = "stat(path) returned no values"; 860 | return 0; 861 | }; 862 | return 1 if $^O eq 'VMS'; # owner delete control at file level 863 | 864 | # Check to see whether owner is neither superuser (or a system uid) nor me 865 | # Use the real uid from the $< variable 866 | # UID is in [4] 867 | if ($info[4] > File::Temp->top_system_uid() && $info[4] != $<) { 868 | 869 | Carp::cluck(sprintf "uid=$info[4] topuid=%s \$<=$< path='$path'", 870 | File::Temp->top_system_uid()); 871 | 872 | $$err_ref = "Directory owned neither by root nor the current user" 873 | if ref($err_ref); 874 | return 0; 875 | } 876 | 877 | # check whether group or other can write file 878 | # use 066 to detect either reading or writing 879 | # use 022 to check writability 880 | # Do it with S_IWOTH and S_IWGRP for portability (maybe) 881 | # mode is in info[2] 882 | if (($info[2] & &Fcntl::S_IWGRP) || # Is group writable? 883 | ($info[2] & &Fcntl::S_IWOTH) ) { # Is world writable? 884 | # Must be a directory 885 | unless (-d _) { 886 | $$err_ref = "Path ($path) is not a directory" 887 | if ref($err_ref); 888 | return 0; 889 | } 890 | # Must have sticky bit set 891 | unless (-k _) { 892 | $$err_ref = "Sticky bit not set on $path when dir is group|world writable" 893 | if ref($err_ref); 894 | return 0; 895 | } 896 | } 897 | 898 | return 1; 899 | } 900 | 901 | # Internal routine to check whether a directory is safe 902 | # for temp files. Safer than _is_safe since it checks for 903 | # the possibility of chown giveaway and if that is a possibility 904 | # checks each directory in the path to see if it is safe (with _is_safe) 905 | 906 | # If _PC_CHOWN_RESTRICTED is not set, does the full test of each 907 | # directory anyway. 908 | 909 | # Takes optional second arg as scalar ref to error reason 910 | 911 | sub _is_verysafe { 912 | 913 | # Need POSIX - but only want to bother if really necessary due to overhead 914 | require POSIX; 915 | 916 | my $path = shift; 917 | print "_is_verysafe testing $path\n" if $DEBUG; 918 | return 1 if $^O eq 'VMS'; # owner delete control at file level 919 | 920 | my $err_ref = shift; 921 | 922 | # Should Get the value of _PC_CHOWN_RESTRICTED if it is defined 923 | # and If it is not there do the extensive test 924 | my $chown_restricted; 925 | $chown_restricted = &POSIX::_PC_CHOWN_RESTRICTED() 926 | if eval { &POSIX::_PC_CHOWN_RESTRICTED(); 1}; 927 | 928 | # If chown_resticted is set to some value we should test it 929 | if (defined $chown_restricted) { 930 | 931 | # Return if the current directory is safe 932 | return _is_safe($path,$err_ref) if POSIX::sysconf( $chown_restricted ); 933 | 934 | } 935 | 936 | # To reach this point either, the _PC_CHOWN_RESTRICTED symbol 937 | # was not avialable or the symbol was there but chown giveaway 938 | # is allowed. Either way, we now have to test the entire tree for 939 | # safety. 940 | 941 | # Convert path to an absolute directory if required 942 | unless (File::Spec->file_name_is_absolute($path)) { 943 | $path = File::Spec->rel2abs($path); 944 | } 945 | 946 | # Split directory into components - assume no file 947 | my ($volume, $directories, undef) = File::Spec->splitpath( $path, 1); 948 | 949 | # Slightly less efficient than having a function in File::Spec 950 | # to chop off the end of a directory or even a function that 951 | # can handle ../ in a directory tree 952 | # Sometimes splitdir() returns a blank at the end 953 | # so we will probably check the bottom directory twice in some cases 954 | my @dirs = File::Spec->splitdir($directories); 955 | 956 | # Concatenate one less directory each time around 957 | foreach my $pos (0.. $#dirs) { 958 | # Get a directory name 959 | my $dir = File::Spec->catpath($volume, 960 | File::Spec->catdir(@dirs[0.. $#dirs - $pos]), 961 | '' 962 | ); 963 | 964 | print "TESTING DIR $dir\n" if $DEBUG; 965 | 966 | # Check the directory 967 | return 0 unless _is_safe($dir,$err_ref); 968 | 969 | } 970 | 971 | return 1; 972 | } 973 | 974 | 975 | 976 | # internal routine to determine whether unlink works on this 977 | # platform for files that are currently open. 978 | # Returns true if we can, false otherwise. 979 | 980 | # Currently WinNT, OS/2 and VMS can not unlink an opened file 981 | # On VMS this is because the O_EXCL flag is used to open the 982 | # temporary file. Currently I do not know enough about the issues 983 | # on VMS to decide whether O_EXCL is a requirement. 984 | 985 | sub _can_unlink_opened_file { 986 | 987 | if ($^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'VMS' || $^O eq 'dos' || $^O eq 'MacOS') { 988 | return 0; 989 | } else { 990 | return 1; 991 | } 992 | 993 | } 994 | 995 | # internal routine to decide which security levels are allowed 996 | # see safe_level() for more information on this 997 | 998 | # Controls whether the supplied security level is allowed 999 | 1000 | # $cando = _can_do_level( $level ) 1001 | 1002 | sub _can_do_level { 1003 | 1004 | # Get security level 1005 | my $level = shift; 1006 | 1007 | # Always have to be able to do STANDARD 1008 | return 1 if $level == STANDARD; 1009 | 1010 | # Currently, the systems that can do HIGH or MEDIUM are identical 1011 | if ( $^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'cygwin' || $^O eq 'dos' || $^O eq 'MacOS') { 1012 | return 0; 1013 | } else { 1014 | return 1; 1015 | } 1016 | 1017 | } 1018 | 1019 | # This routine sets up a deferred unlinking of a specified 1020 | # filename and filehandle. It is used in the following cases: 1021 | # - Called by unlink0 if an opened file can not be unlinked 1022 | # - Called by tempfile() if files are to be removed on shutdown 1023 | # - Called by tempdir() if directories are to be removed on shutdown 1024 | 1025 | # Arguments: 1026 | # _deferred_unlink( $fh, $fname, $isdir ); 1027 | # 1028 | # - filehandle (so that it can be expclicitly closed if open 1029 | # - filename (the thing we want to remove) 1030 | # - isdir (flag to indicate that we are being given a directory) 1031 | # [and hence no filehandle] 1032 | 1033 | # Status is not referred to since all the magic is done with an END block 1034 | 1035 | { 1036 | # Will set up two lexical variables to contain all the files to be 1037 | # removed. One array for files, another for directories 1038 | # They will only exist in this block 1039 | # This means we only have to set up a single END block to remove all files 1040 | # @files_to_unlink contains an array ref with the filehandle and filename 1041 | my (@files_to_unlink, @dirs_to_unlink); 1042 | 1043 | # Set up an end block to use these arrays 1044 | END { 1045 | # Files 1046 | foreach my $file (@files_to_unlink) { 1047 | # close the filehandle without checking its state 1048 | # in order to make real sure that this is closed 1049 | # if its already closed then I dont care about the answer 1050 | # probably a better way to do this 1051 | close($file->[0]); # file handle is [0] 1052 | 1053 | if (-f $file->[1]) { # file name is [1] 1054 | unlink $file->[1] or warn "Error removing ".$file->[1]; 1055 | } 1056 | } 1057 | # Dirs 1058 | foreach my $dir (@dirs_to_unlink) { 1059 | if (-d $dir) { 1060 | rmtree($dir, $DEBUG, 1); 1061 | } 1062 | } 1063 | 1064 | } 1065 | 1066 | # This is the sub called to register a file for deferred unlinking 1067 | # This could simply store the input parameters and defer everything 1068 | # until the END block. For now we do a bit of checking at this 1069 | # point in order to make sure that (1) we have a file/dir to delete 1070 | # and (2) we have been called with the correct arguments. 1071 | sub _deferred_unlink { 1072 | 1073 | croak 'Usage: _deferred_unlink($fh, $fname, $isdir)' 1074 | unless scalar(@_) == 3; 1075 | 1076 | my ($fh, $fname, $isdir) = @_; 1077 | 1078 | warn "Setting up deferred removal of $fname\n" 1079 | if $DEBUG; 1080 | 1081 | # If we have a directory, check that it is a directory 1082 | if ($isdir) { 1083 | 1084 | if (-d $fname) { 1085 | 1086 | # Directory exists so store it 1087 | # first on VMS turn []foo into [.foo] for rmtree 1088 | $fname = VMS::Filespec::vmspath($fname) if $^O eq 'VMS'; 1089 | push (@dirs_to_unlink, $fname); 1090 | 1091 | } else { 1092 | carp "Request to remove directory $fname could not be completed since it does not exist!\n" if $^W; 1093 | } 1094 | 1095 | } else { 1096 | 1097 | if (-f $fname) { 1098 | 1099 | # file exists so store handle and name for later removal 1100 | push(@files_to_unlink, [$fh, $fname]); 1101 | 1102 | } else { 1103 | carp "Request to remove file $fname could not be completed since it is not there!\n" if $^W; 1104 | } 1105 | 1106 | } 1107 | 1108 | } 1109 | 1110 | 1111 | } 1112 | 1113 | =head1 FUNCTIONS 1114 | 1115 | This section describes the recommended interface for generating 1116 | temporary files and directories. 1117 | 1118 | =over 4 1119 | 1120 | =item B 1121 | 1122 | This is the basic function to generate temporary files. 1123 | The behaviour of the file can be changed using various options: 1124 | 1125 | ($fh, $filename) = tempfile(); 1126 | 1127 | Create a temporary file in the directory specified for temporary 1128 | files, as specified by the tmpdir() function in L. 1129 | 1130 | ($fh, $filename) = tempfile($template); 1131 | 1132 | Create a temporary file in the current directory using the supplied 1133 | template. Trailing `X' characters are replaced with random letters to 1134 | generate the filename. At least four `X' characters must be present 1135 | in the template. 1136 | 1137 | ($fh, $filename) = tempfile($template, SUFFIX => $suffix) 1138 | 1139 | Same as previously, except that a suffix is added to the template 1140 | after the `X' translation. Useful for ensuring that a temporary 1141 | filename has a particular extension when needed by other applications. 1142 | But see the WARNING at the end. 1143 | 1144 | ($fh, $filename) = tempfile($template, DIR => $dir); 1145 | 1146 | Translates the template as before except that a directory name 1147 | is specified. 1148 | 1149 | ($fh, $filename) = tempfile($template, UNLINK => 1); 1150 | 1151 | Return the filename and filehandle as before except that the file is 1152 | automatically removed when the program exits. Default is for the file 1153 | to be removed if a file handle is requested and to be kept if the 1154 | filename is requested. In a scalar context (where no filename is 1155 | returned) the file is always deleted either on exit or when it is closed. 1156 | 1157 | If the template is not specified, a template is always 1158 | automatically generated. This temporary file is placed in tmpdir() 1159 | (L) unless a directory is specified explicitly with the 1160 | DIR option. 1161 | 1162 | $fh = tempfile( $template, DIR => $dir ); 1163 | 1164 | If called in scalar context, only the filehandle is returned 1165 | and the file will automatically be deleted when closed (see 1166 | the description of tmpfile() elsewhere in this document). 1167 | This is the preferred mode of operation, as if you only 1168 | have a filehandle, you can never create a race condition 1169 | by fumbling with the filename. On systems that can not unlink 1170 | an open file or can not mark a file as temporary when it is opened 1171 | (for example, Windows NT uses the C flag)) 1172 | the file is marked for deletion when the program ends (equivalent 1173 | to setting UNLINK to 1). The C flag is ignored if present. 1174 | 1175 | (undef, $filename) = tempfile($template, OPEN => 0); 1176 | 1177 | This will return the filename based on the template but 1178 | will not open this file. Cannot be used in conjunction with 1179 | UNLINK set to true. Default is to always open the file 1180 | to protect from possible race conditions. A warning is issued 1181 | if warnings are turned on. Consider using the tmpnam() 1182 | and mktemp() functions described elsewhere in this document 1183 | if opening the file is not required. 1184 | 1185 | Options can be combined as required. 1186 | 1187 | =cut 1188 | 1189 | sub tempfile { 1190 | 1191 | # Can not check for argument count since we can have any 1192 | # number of args 1193 | 1194 | # Default options 1195 | my %options = ( 1196 | "DIR" => undef, # Directory prefix 1197 | "SUFFIX" => '', # Template suffix 1198 | "UNLINK" => 0, # Do not unlink file on exit 1199 | "OPEN" => 1, # Open file 1200 | ); 1201 | 1202 | # Check to see whether we have an odd or even number of arguments 1203 | my $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef); 1204 | 1205 | # Read the options and merge with defaults 1206 | %options = (%options, @_) if @_; 1207 | 1208 | # First decision is whether or not to open the file 1209 | if (! $options{"OPEN"}) { 1210 | 1211 | warn "tempfile(): temporary filename requested but not opened.\nPossibly unsafe, consider using tempfile() with OPEN set to true\n" 1212 | if $^W; 1213 | 1214 | } 1215 | 1216 | if ($options{"DIR"} and $^O eq 'VMS') { 1217 | 1218 | # on VMS turn []foo into [.foo] for concatenation 1219 | $options{"DIR"} = VMS::Filespec::vmspath($options{"DIR"}); 1220 | } 1221 | 1222 | # Construct the template 1223 | 1224 | # Have a choice of trying to work around the mkstemp/mktemp/tmpnam etc 1225 | # functions or simply constructing a template and using _gettemp() 1226 | # explicitly. Go for the latter 1227 | 1228 | # First generate a template if not defined and prefix the directory 1229 | # If no template must prefix the temp directory 1230 | if (defined $template) { 1231 | if ($options{"DIR"}) { 1232 | 1233 | $template = File::Spec->catfile($options{"DIR"}, $template); 1234 | 1235 | } 1236 | 1237 | } else { 1238 | 1239 | if ($options{"DIR"}) { 1240 | 1241 | $template = File::Spec->catfile($options{"DIR"}, TEMPXXX); 1242 | 1243 | } else { 1244 | 1245 | $template = File::Spec->catfile(File::Spec->tmpdir, TEMPXXX); 1246 | 1247 | } 1248 | 1249 | } 1250 | 1251 | # Now add a suffix 1252 | $template .= $options{"SUFFIX"}; 1253 | 1254 | # Determine whether we should tell _gettemp to unlink the file 1255 | # On unix this is irrelevant and can be worked out after the file is 1256 | # opened (simply by unlinking the open filehandle). On Windows or VMS 1257 | # we have to indicate temporary-ness when we open the file. In general 1258 | # we only want a true temporary file if we are returning just the 1259 | # filehandle - if the user wants the filename they probably do not 1260 | # want the file to disappear as soon as they close it. 1261 | # For this reason, tie unlink_on_close to the return context regardless 1262 | # of OS. 1263 | my $unlink_on_close = ( wantarray ? 0 : 1); 1264 | 1265 | # Create the file 1266 | my ($fh, $path, $errstr); 1267 | croak "Error in tempfile() using $template: $errstr" 1268 | unless (($fh, $path) = _gettemp($template, 1269 | "open" => $options{'OPEN'}, 1270 | "mkdir"=> 0 , 1271 | "unlink_on_close" => $unlink_on_close, 1272 | "suffixlen" => length($options{'SUFFIX'}), 1273 | "ErrStr" => \$errstr, 1274 | ) ); 1275 | 1276 | # Set up an exit handler that can do whatever is right for the 1277 | # system. This removes files at exit when requested explicitly or when 1278 | # system is asked to unlink_on_close but is unable to do so because 1279 | # of OS limitations. 1280 | # The latter should be achieved by using a tied filehandle. 1281 | # Do not check return status since this is all done with END blocks. 1282 | _deferred_unlink($fh, $path, 0) if $options{"UNLINK"}; 1283 | 1284 | # Return 1285 | if (wantarray()) { 1286 | 1287 | if ($options{'OPEN'}) { 1288 | return ($fh, $path); 1289 | } else { 1290 | return (undef, $path); 1291 | } 1292 | 1293 | } else { 1294 | 1295 | # Unlink the file. It is up to unlink0 to decide what to do with 1296 | # this (whether to unlink now or to defer until later) 1297 | unlink0($fh, $path) or croak "Error unlinking file $path using unlink0"; 1298 | 1299 | # Return just the filehandle. 1300 | return $fh; 1301 | } 1302 | 1303 | 1304 | } 1305 | 1306 | =item B 1307 | 1308 | This is the recommended interface for creation of temporary directories. 1309 | The behaviour of the function depends on the arguments: 1310 | 1311 | $tempdir = tempdir(); 1312 | 1313 | Create a directory in tmpdir() (see L). 1314 | 1315 | $tempdir = tempdir( $template ); 1316 | 1317 | Create a directory from the supplied template. This template is 1318 | similar to that described for tempfile(). `X' characters at the end 1319 | of the template are replaced with random letters to construct the 1320 | directory name. At least four `X' characters must be in the template. 1321 | 1322 | $tempdir = tempdir ( DIR => $dir ); 1323 | 1324 | Specifies the directory to use for the temporary directory. 1325 | The temporary directory name is derived from an internal template. 1326 | 1327 | $tempdir = tempdir ( $template, DIR => $dir ); 1328 | 1329 | Prepend the supplied directory name to the template. The template 1330 | should not include parent directory specifications itself. Any parent 1331 | directory specifications are removed from the template before 1332 | prepending the supplied directory. 1333 | 1334 | $tempdir = tempdir ( $template, TMPDIR => 1 ); 1335 | 1336 | Using the supplied template, create the temporary directory in 1337 | a standard location for temporary files. Equivalent to doing 1338 | 1339 | $tempdir = tempdir ( $template, DIR => File::Spec->tmpdir); 1340 | 1341 | but shorter. Parent directory specifications are stripped from the 1342 | template itself. The C option is ignored if C is set 1343 | explicitly. Additionally, C is implied if neither a template 1344 | nor a directory are supplied. 1345 | 1346 | $tempdir = tempdir( $template, CLEANUP => 1); 1347 | 1348 | Create a temporary directory using the supplied template, but 1349 | attempt to remove it (and all files inside it) when the program 1350 | exits. Note that an attempt will be made to remove all files from 1351 | the directory even if they were not created by this module (otherwise 1352 | why ask to clean it up?). The directory removal is made with 1353 | the rmtree() function from the L module. 1354 | Of course, if the template is not specified, the temporary directory 1355 | will be created in tmpdir() and will also be removed at program exit. 1356 | 1357 | =cut 1358 | 1359 | # ' 1360 | 1361 | sub tempdir { 1362 | 1363 | # Can not check for argument count since we can have any 1364 | # number of args 1365 | 1366 | # Default options 1367 | my %options = ( 1368 | "CLEANUP" => 0, # Remove directory on exit 1369 | "DIR" => '', # Root directory 1370 | "TMPDIR" => 0, # Use tempdir with template 1371 | ); 1372 | 1373 | # Check to see whether we have an odd or even number of arguments 1374 | my $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef ); 1375 | 1376 | # Read the options and merge with defaults 1377 | %options = (%options, @_) if @_; 1378 | 1379 | # Modify or generate the template 1380 | 1381 | # Deal with the DIR and TMPDIR options 1382 | if (defined $template) { 1383 | 1384 | # Need to strip directory path if using DIR or TMPDIR 1385 | if ($options{'TMPDIR'} || $options{'DIR'}) { 1386 | 1387 | # Strip parent directory from the filename 1388 | # 1389 | # There is no filename at the end 1390 | $template = VMS::Filespec::vmspath($template) if $^O eq 'VMS'; 1391 | my ($volume, $directories, undef) = File::Spec->splitpath( $template, 1); 1392 | 1393 | # Last directory is then our template 1394 | $template = (File::Spec->splitdir($directories))[-1]; 1395 | 1396 | # Prepend the supplied directory or temp dir 1397 | if ($options{"DIR"}) { 1398 | 1399 | $template = File::Spec->catdir($options{"DIR"}, $template); 1400 | 1401 | } elsif ($options{TMPDIR}) { 1402 | 1403 | # Prepend tmpdir 1404 | $template = File::Spec->catdir(File::Spec->tmpdir, $template); 1405 | 1406 | } 1407 | 1408 | } 1409 | 1410 | } else { 1411 | 1412 | if ($options{"DIR"}) { 1413 | 1414 | $template = File::Spec->catdir($options{"DIR"}, TEMPXXX); 1415 | 1416 | } else { 1417 | 1418 | $template = File::Spec->catdir(File::Spec->tmpdir, TEMPXXX); 1419 | 1420 | } 1421 | 1422 | } 1423 | 1424 | # Create the directory 1425 | my $tempdir; 1426 | my $suffixlen = 0; 1427 | if ($^O eq 'VMS') { # dir names can end in delimiters 1428 | $template =~ m/([\.\]:>]+)$/; 1429 | $suffixlen = length($1); 1430 | } 1431 | if ( ($^O eq 'MacOS') && (substr($template, -1) eq ':') ) { 1432 | # dir name has a trailing ':' 1433 | ++$suffixlen; 1434 | } 1435 | 1436 | my $errstr; 1437 | croak "Error in tempdir() using $template: $errstr" 1438 | unless ((undef, $tempdir) = _gettemp($template, 1439 | "open" => 0, 1440 | "mkdir"=> 1 , 1441 | "suffixlen" => $suffixlen, 1442 | "ErrStr" => \$errstr, 1443 | ) ); 1444 | 1445 | # Install exit handler; must be dynamic to get lexical 1446 | if ( $options{'CLEANUP'} && -d $tempdir) { 1447 | _deferred_unlink(undef, $tempdir, 1); 1448 | } 1449 | 1450 | # Return the dir name 1451 | return $tempdir; 1452 | 1453 | } 1454 | 1455 | =back 1456 | 1457 | =head1 MKTEMP FUNCTIONS 1458 | 1459 | The following functions are Perl implementations of the 1460 | mktemp() family of temp file generation system calls. 1461 | 1462 | =over 4 1463 | 1464 | =item B 1465 | 1466 | Given a template, returns a filehandle to the temporary file and the name 1467 | of the file. 1468 | 1469 | ($fh, $name) = mkstemp( $template ); 1470 | 1471 | In scalar context, just the filehandle is returned. 1472 | 1473 | The template may be any filename with some number of X's appended 1474 | to it, for example F. The trailing X's are replaced 1475 | with unique alphanumeric combinations. 1476 | 1477 | =cut 1478 | 1479 | 1480 | 1481 | sub mkstemp { 1482 | 1483 | croak "Usage: mkstemp(template)" 1484 | if scalar(@_) != 1; 1485 | 1486 | my $template = shift; 1487 | 1488 | my ($fh, $path, $errstr); 1489 | croak "Error in mkstemp using $template: $errstr" 1490 | unless (($fh, $path) = _gettemp($template, 1491 | "open" => 1, 1492 | "mkdir"=> 0 , 1493 | "suffixlen" => 0, 1494 | "ErrStr" => \$errstr, 1495 | ) ); 1496 | 1497 | if (wantarray()) { 1498 | return ($fh, $path); 1499 | } else { 1500 | return $fh; 1501 | } 1502 | 1503 | } 1504 | 1505 | 1506 | =item B 1507 | 1508 | Similar to mkstemp(), except that an extra argument can be supplied 1509 | with a suffix to be appended to the template. 1510 | 1511 | ($fh, $name) = mkstemps( $template, $suffix ); 1512 | 1513 | For example a template of C and suffix of C<.dat> 1514 | would generate a file similar to F. 1515 | 1516 | Returns just the filehandle alone when called in scalar context. 1517 | 1518 | =cut 1519 | 1520 | sub mkstemps { 1521 | 1522 | croak "Usage: mkstemps(template, suffix)" 1523 | if scalar(@_) != 2; 1524 | 1525 | 1526 | my $template = shift; 1527 | my $suffix = shift; 1528 | 1529 | $template .= $suffix; 1530 | 1531 | my ($fh, $path, $errstr); 1532 | croak "Error in mkstemps using $template: $errstr" 1533 | unless (($fh, $path) = _gettemp($template, 1534 | "open" => 1, 1535 | "mkdir"=> 0 , 1536 | "suffixlen" => length($suffix), 1537 | "ErrStr" => \$errstr, 1538 | ) ); 1539 | 1540 | if (wantarray()) { 1541 | return ($fh, $path); 1542 | } else { 1543 | return $fh; 1544 | } 1545 | 1546 | } 1547 | 1548 | =item B 1549 | 1550 | Create a directory from a template. The template must end in 1551 | X's that are replaced by the routine. 1552 | 1553 | $tmpdir_name = mkdtemp($template); 1554 | 1555 | Returns the name of the temporary directory created. 1556 | Returns undef on failure. 1557 | 1558 | Directory must be removed by the caller. 1559 | 1560 | =cut 1561 | 1562 | #' # for emacs 1563 | 1564 | sub mkdtemp { 1565 | 1566 | croak "Usage: mkdtemp(template)" 1567 | if scalar(@_) != 1; 1568 | 1569 | my $template = shift; 1570 | my $suffixlen = 0; 1571 | if ($^O eq 'VMS') { # dir names can end in delimiters 1572 | $template =~ m/([\.\]:>]+)$/; 1573 | $suffixlen = length($1); 1574 | } 1575 | if ( ($^O eq 'MacOS') && (substr($template, -1) eq ':') ) { 1576 | # dir name has a trailing ':' 1577 | ++$suffixlen; 1578 | } 1579 | my ($junk, $tmpdir, $errstr); 1580 | croak "Error creating temp directory from template $template\: $errstr" 1581 | unless (($junk, $tmpdir) = _gettemp($template, 1582 | "open" => 0, 1583 | "mkdir"=> 1 , 1584 | "suffixlen" => $suffixlen, 1585 | "ErrStr" => \$errstr, 1586 | ) ); 1587 | 1588 | return $tmpdir; 1589 | 1590 | } 1591 | 1592 | =item B 1593 | 1594 | Returns a valid temporary filename but does not guarantee 1595 | that the file will not be opened by someone else. 1596 | 1597 | $unopened_file = mktemp($template); 1598 | 1599 | Template is the same as that required by mkstemp(). 1600 | 1601 | =cut 1602 | 1603 | sub mktemp { 1604 | 1605 | croak "Usage: mktemp(template)" 1606 | if scalar(@_) != 1; 1607 | 1608 | my $template = shift; 1609 | 1610 | my ($tmpname, $junk, $errstr); 1611 | croak "Error getting name to temp file from template $template: $errstr" 1612 | unless (($junk, $tmpname) = _gettemp($template, 1613 | "open" => 0, 1614 | "mkdir"=> 0 , 1615 | "suffixlen" => 0, 1616 | "ErrStr" => \$errstr, 1617 | ) ); 1618 | 1619 | return $tmpname; 1620 | } 1621 | 1622 | =back 1623 | 1624 | =head1 POSIX FUNCTIONS 1625 | 1626 | This section describes the re-implementation of the tmpnam() 1627 | and tmpfile() functions described in L 1628 | using the mkstemp() from this module. 1629 | 1630 | Unlike the L implementations, the directory used 1631 | for the temporary file is not specified in a system include 1632 | file (C) but simply depends on the choice of tmpdir() 1633 | returned by L. On some implementations this 1634 | location can be set using the C environment variable, which 1635 | may not be secure. 1636 | If this is a problem, simply use mkstemp() and specify a template. 1637 | 1638 | =over 4 1639 | 1640 | =item B 1641 | 1642 | When called in scalar context, returns the full name (including path) 1643 | of a temporary file (uses mktemp()). The only check is that the file does 1644 | not already exist, but there is no guarantee that that condition will 1645 | continue to apply. 1646 | 1647 | $file = tmpnam(); 1648 | 1649 | When called in list context, a filehandle to the open file and 1650 | a filename are returned. This is achieved by calling mkstemp() 1651 | after constructing a suitable template. 1652 | 1653 | ($fh, $file) = tmpnam(); 1654 | 1655 | If possible, this form should be used to prevent possible 1656 | race conditions. 1657 | 1658 | See L for information on the choice of temporary 1659 | directory for a particular operating system. 1660 | 1661 | =cut 1662 | 1663 | sub tmpnam { 1664 | 1665 | # Retrieve the temporary directory name 1666 | my $tmpdir = File::Spec->tmpdir; 1667 | 1668 | croak "Error temporary directory is not writable" 1669 | if $tmpdir eq ''; 1670 | 1671 | # Use a ten character template and append to tmpdir 1672 | my $template = File::Spec->catfile($tmpdir, TEMPXXX); 1673 | 1674 | if (wantarray() ) { 1675 | return mkstemp($template); 1676 | } else { 1677 | return mktemp($template); 1678 | } 1679 | 1680 | } 1681 | 1682 | =item B 1683 | 1684 | Returns the filehandle of a temporary file. 1685 | 1686 | $fh = tmpfile(); 1687 | 1688 | The file is removed when the filehandle is closed or when the program 1689 | exits. No access to the filename is provided. 1690 | 1691 | If the temporary file can not be created undef is returned. 1692 | Currently this command will probably not work when the temporary 1693 | directory is on an NFS file system. 1694 | 1695 | =cut 1696 | 1697 | sub tmpfile { 1698 | 1699 | # Simply call tmpnam() in a list context 1700 | my ($fh, $file) = tmpnam(); 1701 | 1702 | # Make sure file is removed when filehandle is closed 1703 | # This will fail on NFS 1704 | unlink0($fh, $file) 1705 | or return undef; 1706 | 1707 | return $fh; 1708 | 1709 | } 1710 | 1711 | =back 1712 | 1713 | =head1 ADDITIONAL FUNCTIONS 1714 | 1715 | These functions are provided for backwards compatibility 1716 | with common tempfile generation C library functions. 1717 | 1718 | They are not exported and must be addressed using the full package 1719 | name. 1720 | 1721 | =over 4 1722 | 1723 | =item B 1724 | 1725 | Return the name of a temporary file in the specified directory 1726 | using a prefix. The file is guaranteed not to exist at the time 1727 | the function was called, but such guarantees are good for one 1728 | clock tick only. Always use the proper form of C 1729 | with C if you must open such a filename. 1730 | 1731 | $filename = File::Temp::tempnam( $dir, $prefix ); 1732 | 1733 | Equivalent to running mktemp() with $dir/$prefixXXXXXXXX 1734 | (using unix file convention as an example) 1735 | 1736 | Because this function uses mktemp(), it can suffer from race conditions. 1737 | 1738 | =cut 1739 | 1740 | sub tempnam { 1741 | 1742 | croak 'Usage tempnam($dir, $prefix)' unless scalar(@_) == 2; 1743 | 1744 | my ($dir, $prefix) = @_; 1745 | 1746 | # Add a string to the prefix 1747 | $prefix .= 'XXXXXXXX'; 1748 | 1749 | # Concatenate the directory to the file 1750 | my $template = File::Spec->catfile($dir, $prefix); 1751 | 1752 | return mktemp($template); 1753 | 1754 | } 1755 | 1756 | =back 1757 | 1758 | =head1 UTILITY FUNCTIONS 1759 | 1760 | Useful functions for dealing with the filehandle and filename. 1761 | 1762 | =over 4 1763 | 1764 | =item B 1765 | 1766 | Given an open filehandle and the associated filename, make a safe 1767 | unlink. This is achieved by first checking that the filename and 1768 | filehandle initially point to the same file and that the number of 1769 | links to the file is 1 (all fields returned by stat() are compared). 1770 | Then the filename is unlinked and the filehandle checked once again to 1771 | verify that the number of links on that file is now 0. This is the 1772 | closest you can come to making sure that the filename unlinked was the 1773 | same as the file whose descriptor you hold. 1774 | 1775 | unlink0($fh, $path) or die "Error unlinking file $path safely"; 1776 | 1777 | Returns false on error. The filehandle is not closed since on some 1778 | occasions this is not required. 1779 | 1780 | On some platforms, for example Windows NT, it is not possible to 1781 | unlink an open file (the file must be closed first). On those 1782 | platforms, the actual unlinking is deferred until the program ends and 1783 | good status is returned. A check is still performed to make sure that 1784 | the filehandle and filename are pointing to the same thing (but not at 1785 | the time the end block is executed since the deferred removal may not 1786 | have access to the filehandle). 1787 | 1788 | Additionally, on Windows NT not all the fields returned by stat() can 1789 | be compared. For example, the C and C fields seem to be 1790 | different. Also, it seems that the size of the file returned by stat() 1791 | does not always agree, with C being more accurate than 1792 | C, presumably because of caching issues even when 1793 | using autoflush (this is usually overcome by waiting a while after 1794 | writing to the tempfile before attempting to C it). 1795 | 1796 | Finally, on NFS file systems the link count of the file handle does 1797 | not always go to zero immediately after unlinking. Currently, this 1798 | command is expected to fail on NFS disks. 1799 | 1800 | =cut 1801 | 1802 | sub unlink0 { 1803 | 1804 | croak 'Usage: unlink0(filehandle, filename)' 1805 | unless scalar(@_) == 2; 1806 | 1807 | # Read args 1808 | my ($fh, $path) = @_; 1809 | 1810 | warn "Unlinking $path using unlink0\n" 1811 | if $DEBUG; 1812 | 1813 | # Stat the filehandle 1814 | my @fh = stat $fh; 1815 | 1816 | if ($fh[3] > 1 && $^W) { 1817 | carp "unlink0: fstat found too many links; SB=@fh" if $^W; 1818 | } 1819 | 1820 | # Stat the path 1821 | my @path = stat $path; 1822 | 1823 | unless (@path) { 1824 | carp "unlink0: $path is gone already" if $^W; 1825 | return; 1826 | } 1827 | 1828 | # this is no longer a file, but may be a directory, or worse 1829 | unless (-f _) { 1830 | confess "panic: $path is no longer a file: SB=@fh"; 1831 | } 1832 | 1833 | # Do comparison of each member of the array 1834 | # On WinNT dev and rdev seem to be different 1835 | # depending on whether it is a file or a handle. 1836 | # Cannot simply compare all members of the stat return 1837 | # Select the ones we can use 1838 | my @okstat = (0..$#fh); # Use all by default 1839 | if ($^O eq 'MSWin32') { 1840 | @okstat = (1,2,3,4,5,7,8,9,10); 1841 | } elsif ($^O eq 'os2') { 1842 | @okstat = (0, 2..$#fh); 1843 | } elsif ($^O eq 'VMS') { # device and file ID are sufficient 1844 | @okstat = (0, 1); 1845 | } elsif ($^O eq 'dos') { 1846 | @okstat = (0,2..7,11..$#fh); 1847 | } 1848 | 1849 | # Now compare each entry explicitly by number 1850 | for (@okstat) { 1851 | print "Comparing: $_ : $fh[$_] and $path[$_]\n" if $DEBUG; 1852 | # Use eq rather than == since rdev, blksize, and blocks (6, 11, 1853 | # and 12) will be '' on platforms that do not support them. This 1854 | # is fine since we are only comparing integers. 1855 | unless ($fh[$_] eq $path[$_]) { 1856 | warn "Did not match $_ element of stat\n" if $DEBUG; 1857 | return 0; 1858 | } 1859 | } 1860 | 1861 | # attempt remove the file (does not work on some platforms) 1862 | if (_can_unlink_opened_file()) { 1863 | # XXX: do *not* call this on a directory; possible race 1864 | # resulting in recursive removal 1865 | croak "unlink0: $path has become a directory!" if -d $path; 1866 | unlink($path) or return 0; 1867 | 1868 | # Stat the filehandle 1869 | @fh = stat $fh; 1870 | 1871 | print "Link count = $fh[3] \n" if $DEBUG; 1872 | 1873 | # Make sure that the link count is zero 1874 | # - Cygwin provides deferred unlinking, however, 1875 | # on Win9x the link count remains 1 1876 | # On NFS the link count may still be 1 but we cant know that 1877 | # we are on NFS 1878 | return ( $fh[3] == 0 or $^O eq 'cygwin' ? 1 : 0); 1879 | 1880 | } else { 1881 | _deferred_unlink($fh, $path, 0); 1882 | return 1; 1883 | } 1884 | 1885 | } 1886 | 1887 | =back 1888 | 1889 | =head1 PACKAGE VARIABLES 1890 | 1891 | These functions control the global state of the package. 1892 | 1893 | =over 4 1894 | 1895 | =item B 1896 | 1897 | Controls the lengths to which the module will go to check the safety of the 1898 | temporary file or directory before proceeding. 1899 | Options are: 1900 | 1901 | =over 8 1902 | 1903 | =item STANDARD 1904 | 1905 | Do the basic security measures to ensure the directory exists and 1906 | is writable, that the umask() is fixed before opening of the file, 1907 | that temporary files are opened only if they do not already exist, and 1908 | that possible race conditions are avoided. Finally the L 1909 | function is used to remove files safely. 1910 | 1911 | =item MEDIUM 1912 | 1913 | In addition to the STANDARD security, the output directory is checked 1914 | to make sure that it is owned either by root or the user running the 1915 | program. If the directory is writable by group or by other, it is then 1916 | checked to make sure that the sticky bit is set. 1917 | 1918 | Will not work on platforms that do not support the C<-k> test 1919 | for sticky bit. 1920 | 1921 | =item HIGH 1922 | 1923 | In addition to the MEDIUM security checks, also check for the 1924 | possibility of ``chown() giveaway'' using the L 1925 | sysconf() function. If this is a possibility, each directory in the 1926 | path is checked in turn for safeness, recursively walking back to the 1927 | root directory. 1928 | 1929 | For platforms that do not support the L 1930 | C<_PC_CHOWN_RESTRICTED> symbol (for example, Windows NT) it is 1931 | assumed that ``chown() giveaway'' is possible and the recursive test 1932 | is performed. 1933 | 1934 | =back 1935 | 1936 | The level can be changed as follows: 1937 | 1938 | File::Temp->safe_level( File::Temp::HIGH ); 1939 | 1940 | The level constants are not exported by the module. 1941 | 1942 | Currently, you must be running at least perl v5.6.0 in order to 1943 | run with MEDIUM or HIGH security. This is simply because the 1944 | safety tests use functions from L that are not 1945 | available in older versions of perl. The problem is that the version 1946 | number for Fcntl is the same in perl 5.6.0 and in 5.005_03 even though 1947 | they are different versions. 1948 | 1949 | On systems that do not support the HIGH or MEDIUM safety levels 1950 | (for example Win NT or OS/2) any attempt to change the level will 1951 | be ignored. The decision to ignore rather than raise an exception 1952 | allows portable programs to be written with high security in mind 1953 | for the systems that can support this without those programs failing 1954 | on systems where the extra tests are irrelevant. 1955 | 1956 | If you really need to see whether the change has been accepted 1957 | simply examine the return value of C. 1958 | 1959 | $newlevel = File::Temp->safe_level( File::Temp::HIGH ); 1960 | die "Could not change to high security" 1961 | if $newlevel != File::Temp::HIGH; 1962 | 1963 | =cut 1964 | 1965 | { 1966 | # protect from using the variable itself 1967 | my $LEVEL = STANDARD; 1968 | sub safe_level { 1969 | my $self = shift; 1970 | if (@_) { 1971 | my $level = shift; 1972 | if (($level != STANDARD) && ($level != MEDIUM) && ($level != HIGH)) { 1973 | carp "safe_level: Specified level ($level) not STANDARD, MEDIUM or HIGH - ignoring\n" if $^W; 1974 | } else { 1975 | # Dont allow this on perl 5.005 or earlier 1976 | if ($] < 5.006 && $level != STANDARD) { 1977 | # Cant do MEDIUM or HIGH checks 1978 | croak "Currently requires perl 5.006 or newer to do the safe checks"; 1979 | } 1980 | # Check that we are allowed to change level 1981 | # Silently ignore if we can not. 1982 | $LEVEL = $level if _can_do_level($level); 1983 | } 1984 | } 1985 | return $LEVEL; 1986 | } 1987 | } 1988 | 1989 | =item TopSystemUID 1990 | 1991 | This is the highest UID on the current system that refers to a root 1992 | UID. This is used to make sure that the temporary directory is 1993 | owned by a system UID (C, C, C etc) rather than 1994 | simply by root. 1995 | 1996 | This is required since on many unix systems C is not owned 1997 | by root. 1998 | 1999 | Default is to assume that any UID less than or equal to 10 is a root 2000 | UID. 2001 | 2002 | File::Temp->top_system_uid(10); 2003 | my $topid = File::Temp->top_system_uid; 2004 | 2005 | This value can be adjusted to reduce security checking if required. 2006 | The value is only relevant when C is set to MEDIUM or higher. 2007 | 2008 | =back 2009 | 2010 | =cut 2011 | 2012 | { 2013 | my $TopSystemUID = 10; 2014 | sub top_system_uid { 2015 | my $self = shift; 2016 | if (@_) { 2017 | my $newuid = shift; 2018 | croak "top_system_uid: UIDs should be numeric" 2019 | unless $newuid =~ /^\d+$/s; 2020 | $TopSystemUID = $newuid; 2021 | } 2022 | return $TopSystemUID; 2023 | } 2024 | } 2025 | 2026 | =head1 WARNING 2027 | 2028 | For maximum security, endeavour always to avoid ever looking at, 2029 | touching, or even imputing the existence of the filename. You do not 2030 | know that that filename is connected to the same file as the handle 2031 | you have, and attempts to check this can only trigger more race 2032 | conditions. It's far more secure to use the filehandle alone and 2033 | dispense with the filename altogether. 2034 | 2035 | If you need to pass the handle to something that expects a filename 2036 | then, on a unix system, use C<"/dev/fd/" . fileno($fh)> for arbitrary 2037 | programs, or more generally C<< "+<=&" . fileno($fh) >> for Perl 2038 | programs. You will have to clear the close-on-exec bit on that file 2039 | descriptor before passing it to another process. 2040 | 2041 | use Fcntl qw/F_SETFD F_GETFD/; 2042 | fcntl($tmpfh, F_SETFD, 0) 2043 | or die "Can't clear close-on-exec flag on temp fh: $!\n"; 2044 | 2045 | =head2 Temporary files and NFS 2046 | 2047 | Some problems are associated with using temporary files that reside 2048 | on NFS file systems and it is recommended that a local filesystem 2049 | is used whenever possible. Some of the security tests will most probably 2050 | fail when the temp file is not local. Additionally, be aware that 2051 | the performance of I/O operations over NFS will not be as good as for 2052 | a local disk. 2053 | 2054 | =head1 HISTORY 2055 | 2056 | Originally began life in May 1999 as an XS interface to the system 2057 | mkstemp() function. In March 2000, the OpenBSD mkstemp() code was 2058 | translated to Perl for total control of the code's 2059 | security checking, to ensure the presence of the function regardless of 2060 | operating system and to help with portability. 2061 | 2062 | =head1 SEE ALSO 2063 | 2064 | L, L, L, L 2065 | 2066 | See L and L for different implementations of 2067 | temporary file handling. 2068 | 2069 | =head1 AUTHOR 2070 | 2071 | Tim Jenness Et.jenness@jach.hawaii.eduE 2072 | 2073 | Copyright (C) 1999-2001 Tim Jenness and the UK Particle Physics and 2074 | Astronomy Research Council. All Rights Reserved. This program is free 2075 | software; you can redistribute it and/or modify it under the same 2076 | terms as Perl itself. 2077 | 2078 | Original Perl implementation loosely based on the OpenBSD C code for 2079 | mkstemp(). Thanks to Tom Christiansen for suggesting that this module 2080 | should be written and providing ideas for code improvements and 2081 | security enhancements. 2082 | 2083 | =cut 2084 | 2085 | 2086 | 1; 2087 | -------------------------------------------------------------------------------- /dd-gui.app/Contents/MacOS/bar: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gingerbeardman/dd-gui/5ee8d18b017a0b51fb40101dac13f395aa96b79b/dd-gui.app/Contents/MacOS/bar -------------------------------------------------------------------------------- /dd-gui.app/Contents/MacOS/dd.command: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | clear 3 | echo 'Devices:' 4 | echo 5 | diskutil list -------------------------------------------------------------------------------- /dd-gui.app/Contents/MacOS/ddgui: -------------------------------------------------------------------------------- 1 | #!/usr/bin/php 2 | 5 | // 0.21, 17 Sept 2009 6 | 7 | start: 8 | $conf = << $of 122 | 123 | if [ -b "$of" ] 124 | then 125 | sleep 1 126 | diskutil quiet mountDisk $of 127 | fi 128 | 129 | open -R $of 130 | printf '\a' 131 | 132 | echo 133 | echo 'Done! You may close this window.' 134 | echo 135 | BASH; 136 | file_put_contents($ddc, $script); 137 | exec("chmod +x $ddc"); 138 | exec("open $ddc"); 139 | } 140 | 141 | /** 142 | * Wrapper function for accessing Pashua from PHP 143 | * 144 | * @param string Configuration string to pass to Pashua 145 | * @param optional string Configuration string's text encoding (default: "macroman") 146 | * @param optional string Absolute filesystem path to directory containing Pashua 147 | * @return array Associative array of values returned by Pashua 148 | * @author Carsten Bluem 149 | * @version 2005-04-26 150 | */ 151 | function pashua_run($conf, $encoding = 'macroman', $apppath = null) { 152 | 153 | // Check for safe mode 154 | if (ini_get('safe_mode')) { 155 | die("\n Sorry, to use Pashua you will have to disable\n". 156 | " safe mode or change the function pashua_run()\n". 157 | " to fit your environment.\n\n"); 158 | } 159 | 160 | // Write configuration string to temporary config file 161 | $configfile = tempnam('/tmp', 'Pashua_'); 162 | $fp = fopen($configfile, 'w') or user_error("Error trying to open $configfile", E_USER_ERROR); 163 | fwrite($fp, $conf); 164 | fclose ($fp); 165 | 166 | // Try to figure out the path to pashua 167 | $bundlepath = "Pashua.app/Contents/MacOS/Pashua"; 168 | $path = ''; 169 | 170 | if ($apppath) { 171 | // A directory path was given 172 | $path = str_replace('//', '/', $apppath.'/'.$bundlepath); 173 | } 174 | else { 175 | // Try find Pashua in one of the common places 176 | $paths = array( 177 | dirname(__FILE__).'/Pashua', 178 | dirname(__FILE__)."/$bundlepath", 179 | "./$bundlepath", 180 | "/Applications/$bundlepath", 181 | "$_SERVER[HOME]/Applications/$bundlepath" 182 | ); 183 | // Then, look in each of these places 184 | foreach ($paths as $searchpath) { 185 | if (file_exists($searchpath) and 186 | is_executable($searchpath)) { 187 | // Looks like Pashua is in $dir --> exit the loop 188 | $path = $searchpath; 189 | break; 190 | } 191 | } 192 | } 193 | 194 | // Raise an error if we didn't find the application 195 | if (empty($path)) { 196 | user_error('Unable to locate Pashua', E_USER_ERROR); 197 | } 198 | 199 | // Call pashua binary with config file as argument and read result 200 | $cmd = preg_match('#^\w+$#', $encoding) ? "'$path' -e $encoding $configfile" : "'$path' $configfile"; 201 | $result = `$cmd`; 202 | 203 | // Remove config file 204 | unlink($configfile); 205 | 206 | // Init result array 207 | $parsed = array(); 208 | 209 | // Parse result 210 | foreach (explode("\n", $result) as $line) { 211 | preg_match('/^(\w+)=(.*)$/', $line, $matches); 212 | if (empty($matches) or empty($matches[1])) { 213 | continue; 214 | } 215 | $parsed[$matches[1]] = $matches[2]; 216 | } 217 | 218 | return $parsed; 219 | 220 | } // function pashua_run($conf) 221 | 222 | ?> -------------------------------------------------------------------------------- /dd-gui.app/Contents/MacOS/dev.php: -------------------------------------------------------------------------------- 1 | #!/usr/bin/php 2 | 43 | * @version 2005-04-26 44 | */ 45 | function pashua_run($conf, $encoding = 'macroman', $apppath = null) { 46 | 47 | // Check for safe mode 48 | if (ini_get('safe_mode')) { 49 | die("\n Sorry, to use Pashua you will have to disable\n". 50 | " safe mode or change the function pashua_run()\n". 51 | " to fit your environment.\n\n"); 52 | } 53 | 54 | // Write configuration string to temporary config file 55 | $configfile = tempnam('/tmp', 'Pashua_'); 56 | $fp = fopen($configfile, 'w') or user_error("Error trying to open $configfile", E_USER_ERROR); 57 | fwrite($fp, $conf); 58 | fclose ($fp); 59 | 60 | // Try to figure out the path to pashua 61 | $bundlepath = "Pashua.app/Contents/MacOS/Pashua"; 62 | $path = ''; 63 | 64 | if ($apppath) { 65 | // A directory path was given 66 | $path = str_replace('//', '/', $apppath.'/'.$bundlepath); 67 | } 68 | else { 69 | // Try find Pashua in one of the common places 70 | $paths = array( 71 | dirname(__FILE__).'/Pashua', 72 | dirname(__FILE__)."/$bundlepath", 73 | "./$bundlepath", 74 | "/Applications/$bundlepath", 75 | "$_SERVER[HOME]/Applications/$bundlepath" 76 | ); 77 | // Then, look in each of these places 78 | foreach ($paths as $searchpath) { 79 | if (file_exists($searchpath) and 80 | is_executable($searchpath)) { 81 | // Looks like Pashua is in $dir --> exit the loop 82 | $path = $searchpath; 83 | break; 84 | } 85 | } 86 | } 87 | 88 | // Raise an error if we didn't find the application 89 | if (empty($path)) { 90 | user_error('Unable to locate Pashua', E_USER_ERROR); 91 | } 92 | 93 | // Call pashua binary with config file as argument and read result 94 | $cmd = preg_match('#^\w+$#', $encoding) ? "'$path' -e $encoding $configfile" : "'$path' $configfile"; 95 | $result = `$cmd`; 96 | 97 | // Remove config file 98 | unlink($configfile); 99 | 100 | // Init result array 101 | $parsed = array(); 102 | 103 | // Parse result 104 | foreach (explode("\n", $result) as $line) { 105 | preg_match('/^(\w+)=(.*)$/', $line, $matches); 106 | if (empty($matches) or empty($matches[1])) { 107 | continue; 108 | } 109 | $parsed[$matches[1]] = $matches[2]; 110 | } 111 | 112 | return $parsed; 113 | 114 | } // function pashua_run($conf) 115 | ?> -------------------------------------------------------------------------------- /dd-gui.app/Contents/PkgInfo: -------------------------------------------------------------------------------- 1 | APPL???? -------------------------------------------------------------------------------- /dd-gui.app/Contents/Resources/English.lproj/InfoPlist.strings: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gingerbeardman/dd-gui/5ee8d18b017a0b51fb40101dac13f395aa96b79b/dd-gui.app/Contents/Resources/English.lproj/InfoPlist.strings -------------------------------------------------------------------------------- /dd-gui.app/Contents/Resources/English.lproj/MainMenu.nib/classes.nib: -------------------------------------------------------------------------------- 1 | { 2 | IBClasses = ( 3 | {CLASS = AppController; LANGUAGE = ObjC; SUPERCLASS = NSObject; }, 4 | {CLASS = FirstResponder; LANGUAGE = ObjC; SUPERCLASS = NSObject; } 5 | ); 6 | IBVersion = 1; 7 | } -------------------------------------------------------------------------------- /dd-gui.app/Contents/Resources/English.lproj/MainMenu.nib/info.nib: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | IBDocumentLocation 6 | 20 20 356 240 0 0 1280 1002 7 | IBEditorPositions 8 | 9 | 29 10 | 33 331 276 44 0 0 1280 1002 11 | 12 | IBFramework Version 13 | 443.0 14 | IBOldestOS 15 | 3 16 | IBOpenObjects 17 | 18 | 29 19 | 20 | IBSystem Version 21 | 8F46 22 | 23 | 24 | -------------------------------------------------------------------------------- /dd-gui.app/Contents/Resources/English.lproj/MainMenu.nib/keyedobjects.nib: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gingerbeardman/dd-gui/5ee8d18b017a0b51fb40101dac13f395aa96b79b/dd-gui.app/Contents/Resources/English.lproj/MainMenu.nib/keyedobjects.nib -------------------------------------------------------------------------------- /dd-gui.app/Contents/Resources/English.lproj/dict.strings: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gingerbeardman/dd-gui/5ee8d18b017a0b51fb40101dac13f395aa96b79b/dd-gui.app/Contents/Resources/English.lproj/dict.strings -------------------------------------------------------------------------------- /dd-gui.app/Contents/Resources/French.lproj/MainMenu.nib/classes.nib: -------------------------------------------------------------------------------- 1 | { 2 | IBClasses = ( 3 | {CLASS = AppController; LANGUAGE = ObjC; SUPERCLASS = NSObject; }, 4 | {CLASS = FirstResponder; LANGUAGE = ObjC; SUPERCLASS = NSObject; } 5 | ); 6 | IBVersion = 1; 7 | } -------------------------------------------------------------------------------- /dd-gui.app/Contents/Resources/French.lproj/MainMenu.nib/info.nib: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | IBDocumentLocation 6 | 34 20 356 240 0 0 1280 1002 7 | IBEditorPositions 8 | 9 | 29 10 | 69 255 316 44 0 0 1280 1002 11 | 12 | IBFramework Version 13 | 443.0 14 | IBSystem Version 15 | 8F46 16 | 17 | 18 | -------------------------------------------------------------------------------- /dd-gui.app/Contents/Resources/French.lproj/MainMenu.nib/keyedobjects.nib: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gingerbeardman/dd-gui/5ee8d18b017a0b51fb40101dac13f395aa96b79b/dd-gui.app/Contents/Resources/French.lproj/MainMenu.nib/keyedobjects.nib -------------------------------------------------------------------------------- /dd-gui.app/Contents/Resources/French.lproj/dict.strings: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gingerbeardman/dd-gui/5ee8d18b017a0b51fb40101dac13f395aa96b79b/dd-gui.app/Contents/Resources/French.lproj/dict.strings -------------------------------------------------------------------------------- /dd-gui.app/Contents/Resources/German.lproj/MainMenu.nib/classes.nib: -------------------------------------------------------------------------------- 1 | { 2 | IBClasses = ( 3 | {CLASS = AppController; LANGUAGE = ObjC; SUPERCLASS = NSObject; }, 4 | {CLASS = FirstResponder; LANGUAGE = ObjC; SUPERCLASS = NSObject; } 5 | ); 6 | IBVersion = 1; 7 | } -------------------------------------------------------------------------------- /dd-gui.app/Contents/Resources/German.lproj/MainMenu.nib/info.nib: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | IBDocumentLocation 6 | 54 14 356 240 0 0 1280 1002 7 | IBEditorPositions 8 | 9 | 29 10 | 75 373 472 44 0 0 1280 1002 11 | 12 | IBFramework Version 13 | 443.0 14 | IBOpenObjects 15 | 16 | 29 17 | 18 | IBSystem Version 19 | 8F46 20 | 21 | 22 | -------------------------------------------------------------------------------- /dd-gui.app/Contents/Resources/German.lproj/MainMenu.nib/keyedobjects.nib: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gingerbeardman/dd-gui/5ee8d18b017a0b51fb40101dac13f395aa96b79b/dd-gui.app/Contents/Resources/German.lproj/MainMenu.nib/keyedobjects.nib -------------------------------------------------------------------------------- /dd-gui.app/Contents/Resources/German.lproj/dict.strings: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gingerbeardman/dd-gui/5ee8d18b017a0b51fb40101dac13f395aa96b79b/dd-gui.app/Contents/Resources/German.lproj/dict.strings --------------------------------------------------------------------------------