![]() ![]() | ![]() |
- BUG#3065, / in gfilename were troublesome
1: # The LearningOnline Network with CAPA 2: # Handler to rename files, etc, in construction space 3: # 4: # This file responds to the various buttons and events 5: # in the top frame of the construction space directory. 6: # Each event is processed in two phases. The first phase 7: # presents a page that describes the proposed action to the user 8: # and requests confirmation. The second phase commits the action 9: # and displays a page showing the results of the action. 10: # 11: # 12: # $Id: loncfile.pm,v 1.63 2004/09/10 20:05:03 albertel Exp $ 13: # 14: # Copyright Michigan State University Board of Trustees 15: # 16: # This file is part of the LearningOnline Network with CAPA (LON-CAPA). 17: # 18: # LON-CAPA is free software; you can redistribute it and/or modify 19: # it under the terms of the GNU General Public License as published by 20: # the Free Software Foundation; either version 2 of the License, or 21: # (at your option) any later version. 22: # 23: # LON-CAPA is distributed in the hope that it will be useful, 24: # but WITHOUT ANY WARRANTY; without even the implied warranty of 25: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 26: # GNU General Public License for more details. 27: # 28: # You should have received a copy of the GNU General Public License 29: # along with LON-CAPA; if not, write to the Free Software 30: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 31: # 32: # /home/httpd/html/adm/gpl.txt 33: # 34: # http://www.lon-capa.org/ 35: # 36: =pod 37: 38: =head1 NAME 39: 40: Apache::loncfile - Construction space file management. 41: 42: =head1 SYNOPSIS 43: 44: Content handler for buttons on the top frame of the construction space 45: directory. 46: 47: =head1 INTRODUCTION 48: 49: loncfile is invoked when buttons in the top frame of the construction 50: space directory listing are clicked. All operations proceed in two phases. 51: The first phase describes to the user exactly what will be done. If the user 52: confirms the operation, the second phase commits the operation and indicates 53: completion. When the user dismisses the output of phase2, they are returned to 54: an "appropriate" directory listing in general. 55: 56: This is part of the LearningOnline Network with CAPA project 57: described at http://www.lon-capa.org. 58: 59: =head2 Subroutines 60: 61: =cut 62: 63: package Apache::loncfile; 64: 65: use strict; 66: use Apache::File; 67: use File::Basename; 68: use File::Copy; 69: use HTML::Entities(); 70: use Apache::Constants qw(:common :http :methods); 71: use Apache::loncacc; 72: use Apache::Log (); 73: use Apache::lonnet; 74: use Apache::loncommon(); 75: use Apache::lonlocal; 76: 77: my $DEBUG=0; 78: my $r; # Needs to be global for some stuff RF. 79: 80: =pod 81: 82: =item Debug($request, $message) 83: 84: If debugging is enabled puts out a debugging message determined by the 85: caller. The debug message goes to the Apache error log file. Debugging 86: is enabled by setting the module global DEBUG variable to nonzero (TRUE). 87: 88: Parameters: 89: 90: =over 4 91: 92: =item $request - The current request operation. 93: 94: =item $message - The message to put in the log file. 95: 96: =back 97: 98: Returns: 99: nothing. 100: 101: =cut 102: 103: sub Debug { 104: 105: # Marshall the parameters. 106: 107: my $r = shift; 108: my $log = $r->log; 109: my $message = shift; 110: 111: # Put out the indicated message butonly if DEBUG is true. 112: 113: if ($DEBUG) { 114: $r->log_reason($message); 115: } 116: } 117: 118: =pod 119: 120: =item URLToPath($url) 121: 122: Convert a URL to a file system path. 123: 124: In order to manipulate the construction space objects, it is necessary 125: to access url identified objects a filespace objects. This function 126: translates a construction space URL to a file system path. 127: Parameters: 128: 129: =over 4 130: 131: =item Url - string [in] The url to convert. 132: 133: =back 134: 135: Returns: 136: 137: =over 4 138: 139: =item The corresponding file system path. 140: 141: =back 142: 143: Global References 144: 145: =over 4 146: 147: =item $r - Request object [in] Referenced in the &Debug calls. 148: 149: =back 150: 151: =cut 152: 153: sub URLToPath { 154: my $Url = shift; 155: &Debug($r, "UrlToPath got: $Url"); 156: $Url=~ s/\/+/\//g; 157: $Url=~ s/^http\:\/\/[^\/]+//; 158: $Url=~ s/^\///; 159: $Url=~ s/(\~|priv\/)(\w+)\//\/home\/$2\/public_html\//; 160: &Debug($r, "Returning $Url \n"); 161: return $Url; 162: } 163: 164: sub url { 165: my $fn=shift; 166: $fn=~s/^\/home\/(\w+)\/public\_html/\/priv\/$1/; 167: $fn=&HTML::Entities::encode($fn,'<>"&'); 168: return $fn; 169: } 170: 171: sub display { 172: my $fn=shift; 173: $fn=~s-^/home/(\w+)/public_html-/priv/$1-; 174: return '<tt>'.$fn.'</tt>'; 175: } 176: 177: 178: # see if the file is 179: # a) published (return 0 if not) 180: # b) if, so obsolete (return 0 if not) 181: 182: sub obsolete_unpub { 183: my ($user,$domain,$construct)=@_; 184: my $published=$construct; 185: $published=~ 186: s/^\/home\/$user\/public\_html\//\/home\/httpd\/html\/res\/$domain\/$user\//; 187: if (-e $published) { 188: if (&Apache::lonnet::metadata($published,'obsolete')) { 189: return 1; 190: } 191: return 0; 192: } else { 193: return 1; 194: } 195: } 196: 197: 198: 199: =pod 200: 201: =item exists($user, $domain, $file) 202: 203: Determine if a resource file name has been published or exists 204: in the construction space. 205: 206: Parameters: 207: 208: =over 4 209: 210: =item $user - string [in] - Name of the user for which to check. 211: 212: =item $domain - string [in] - Name of the domain in which the resource 213: might have been published. 214: 215: =item $file - string [in] - Name of the file. 216: 217: =back 218: 219: Returns: 220: 221: =over 4 222: 223: =item string - Either where the resource exists as an html string that can 224: be embedded in a dialog or an empty string if the resource 225: does not exist. 226: 227: =back 228: 229: =cut 230: 231: sub exists { 232: my ($user, $domain, $construct) = @_; 233: my $published=$construct; 234: $published=~ 235: s/^\/home\/$user\/public\_html\//\/home\/httpd\/html\/res\/$domain\/$user\//; 236: my $result=''; 237: if ( -d $construct ) { 238: return &mt('Error: destination for operation is an existing directory.'); 239: } 240: if ( -e $published) { 241: $result.='<p><font color="red">'.&mt('Warning: target file exists, and has been published!').'</font></p>'; 242: } elsif ( -e $construct) { 243: $result.='<p><font color="red">'.&mt('Warning: target file exists!').'</font></p>'; 244: } 245: return $result; 246: } 247: 248: =pod 249: 250: =item checksuffix($old, $new) 251: 252: Determine if a resource filename suffix (the stuff after the .) would change 253: as a result of this operation. 254: 255: Parameters: 256: 257: =over 4 258: 259: =item $old = string [in] Previous filename. 260: 261: =item $new = string [in] Resultant filename. 262: 263: =back 264: 265: Returns: 266: 267: =over 4 268: 269: =item Empty string if everything worked. 270: 271: =item String containing an error message if there was a problem. 272: 273: =back 274: 275: =cut 276: 277: sub checksuffix { 278: my ($old,$new) = @_; 279: my $result; 280: my $oldsuffix; 281: my $newsuffix; 282: if ($new=~m:(.*/*)([^/]+)\.(\w+)$:) { $newsuffix=$3; } 283: if ($old=~m:(.*)/+([^/]+)\.(\w+)$:) { $oldsuffix=$3; } 284: if ($oldsuffix ne $newsuffix) { 285: $result.= 286: '<p><font color="red">'.&mt('Warning: change of MIME type!').'</font></p>'; 287: } 288: return $result; 289: } 290: 291: sub cleanDest { 292: my ($request,$dest,$subdir,$fn)=@_; 293: #remove bad characters 294: my $foundbad=0; 295: if ($subdir && $dest =~/\./) { 296: $foundbad=1; 297: $dest=~s/\.//g; 298: } 299: if ($dest=~/[\#\?&%\"]/) { 300: $foundbad=1; 301: $dest=~s/[\#\?&%\"]//g; 302: } 303: if ($dest=~m|/|) { 304: my ($newpath)=($dest=~m|(.*)/|); 305: if (! -d "$fn/$newpath") { 306: $request->print("<p><font color=\"red\">".&mt('You request to create file in directory [_1] which doesn\'t exist. The requested directory path has been removed from the requested file name.','"<tt>'.$newpath.'</tt>"')."</font></p>"); 307: $dest=~s|.*/||; 308: } 309: } 310: if ($foundbad) { 311: $request->print("<p><font color=\"red\">".&mt('Invalid characters in requested name have been removed.')."</font></p>"); 312: } 313: return $dest; 314: } 315: 316: sub relativeDest { 317: my ($fn,$newfilename,$uname)=@_; 318: if ($newfilename=~/^\//) { 319: # absolute, simply add path 320: $newfilename='/home/'.$uname.'/public_html/'; 321: } else { 322: my $dir=$fn; 323: $dir=~s/\/[^\/]+$//; 324: $newfilename=$dir.'/'.$newfilename; 325: } 326: $newfilename=~s://+:/:g; # remove duplicate / 327: while ($newfilename=~m:/\.\./:) { 328: $newfilename=~ s:/[^/]+/\.\./:/:g; #remove dir/.. 329: } 330: return $newfilename; 331: } 332: 333: =pod 334: 335: =item CloseForm1($request, $user, $file) 336: 337: Close of a form on the successful completion of phase 1 processing 338: 339: Parameters: 340: 341: =over 4 342: 343: =item $request - Apache Request Object [in] - Apache server request object. 344: 345: =item $cancelurl - the url to go to on cancel. 346: 347: =back 348: 349: =cut 350: 351: sub CloseForm1 { 352: my ($request, $fn) = @_; 353: $request->print('<p><input type="submit" value="'.&mt('Continue').'" /></p></form>'); 354: $request->print('<form action="'.&url($fn). 355: '" method="POST"><p><input type="submit" value="'.&mt('Cancel').'" /></p></form>'); 356: } 357: 358: 359: =pod 360: 361: =item CloseForm2($request, $user, $directory) 362: 363: Successfully close off the phase 2 form. 364: 365: Parameters: 366: 367: =over 4 368: 369: =item $request - Apache Request object [in] - The request that is being 370: executed. 371: 372: =item $user - string [in] - Name of the user that is initiating the 373: request. 374: 375: =item $directory - string [in] - Directory in which the operation is 376: being done relative to the top level construction space 377: directory. 378: 379: =back 380: 381: =cut 382: 383: sub CloseForm2 { 384: my ($request, $user, $fn) = @_; 385: $request->print('<h3><a href="'.&url($fn).'/">'.&mt('Done').'</a></h3>'); 386: } 387: 388: =pod 389: 390: =item Rename1($request, $filename, $user, $domain, $dir) 391: 392: Perform phase 1 processing of the file rename operation. 393: 394: Parameters: 395: 396: =over 4 397: 398: =item $request - Apache Request Object [in] The request object for the 399: current request. 400: 401: =item $filename - The filename relative to construction space. 402: 403: =item $user - Name of the user making the request. 404: 405: =item $domain - User login domain. 406: 407: =item $dir - Directory specification of the path to the file. 408: 409: =back 410: 411: Side effects: 412: 413: =over 4 414: 415: =item A new form is displayed prompting for confirmation. The newfilename 416: hidden field of this form is loaded with 417: new filename relative to the current directory ($dir). 418: 419: =back 420: 421: =cut 422: 423: sub Rename1 { 424: my ($request, $user, $domain, $fn, $newfilename, $style) = @_; 425: 426: if(-e $fn) { 427: if($newfilename) { 428: # is dest a dir 429: if ($style eq 'move') { 430: if (-d $newfilename) { 431: if ($fn =~ m|/([^/]*)$|) { $newfilename .= '/'.$1; } 432: } 433: } 434: if ($newfilename =~ m|/[^\.]+$|) { 435: #no extension add on original extension 436: if ($fn =~ m|/[^\.]*\.([^\.]+)$|) { 437: $newfilename.='.'.$1; 438: } 439: } 440: $request->print(&checksuffix($fn, $newfilename)); 441: #renaming a dir, delete the trailing / 442: #remove second to last element for current dir 443: if (-d $fn) { 444: $newfilename=~/\.(\w+)$/; 445: if (&Apache::loncommon::fileembstyle($1) eq 'ssi') { 446: $request->print('<br /><font color="red">'. 447: &mt('Cannot change MIME type of a directory'). 448: '</font>'. 449: '<br /><a href="'.&url($fn).'">'.&mt('Cancel').'</a>'); 450: return; 451: } 452: $newfilename=~s/\/[^\/]+\/([^\/]+)$/\/$1/; 453: } 454: $newfilename=~s://+:/:g; # remove duplicate / 455: while ($newfilename=~m:/\.\./:) { 456: $newfilename=~ s:/[^/]+/\.\./:/:g; #remove dir/.. 457: } 458: my $return=&exists($user, $domain, $newfilename); 459: $request->print($return); 460: if ($return =~/^Error:/) { 461: $request->print('<br /><a href="'.&url($fn).'">'.&mt('Cancel').'</a>'); 462: return; 463: } 464: unless (&obsolete_unpub($user,$domain,$fn)) { 465: $request->print('<h3>'.&mt('Cannot rename or move non-obsolete published file').'</h3>'. 466: '<br /><a href="'.&url($fn).'">'.&mt('Cancel').'</a>'); 467: return; 468: } 469: my $action; 470: if ($style eq 'rename') { 471: $action=&mt('Rename'); 472: } else { 473: $action=&mt('Move'); 474: } 475: $request->print('<input type="hidden" name="newfilename" value="'. 476: $newfilename. 477: '" /><p>'.$action.' '.&display($fn). 478: '</tt><br />to '.&display($newfilename).'?</p>'); 479: &CloseForm1($request, $fn); 480: } else { 481: $request->print('<p>'.&mt('No new filename specified.').'</p></form>'); 482: return; 483: } 484: } else { 485: $request->print('<p> '.&mt('No such file').': '.&display($fn).'</p></form>'); 486: return; 487: } 488: 489: } 490: 491: =pod 492: 493: =item Delete1 494: 495: Performs phase 1 processing of the delete operation. In phase one 496: we just check to be sure the file exists. 497: 498: Parameters: 499: 500: =over 4 501: 502: =item $request - Apache Request Object [in] request object for the current 503: request. 504: 505: =item $user - string [in] Name of the user initiating the request. 506: 507: =item $domain - string [in] Domain the initiating user is logged in as 508: 509: =item $filename - string [in] Source filename. 510: 511: =back 512: 513: =cut 514: 515: sub Delete1 { 516: my ($request, $user, $domain, $fn) = @_; 517: 518: if( -e $fn) { 519: $request->print('<input type="hidden" name="newfilename" value="'. 520: $fn.'"/>'); 521: unless (&obsolete_unpub($user,$domain,$fn)) { 522: $request->print('<h3>'.&mt('Cannot delete non-obsolete published file').'</h3>'. 523: '<br /><a href="'.&url($fn).'">'.&mt('Cancel').'</a>'); 524: return; 525: } 526: $request->print('<p>'.&mt('Delete').' '.&display($fn).'?</p>'); 527: &CloseForm1($request, $fn); 528: } else { 529: $request->print('<p>'.&mt('No such file').': '.&display($fn).'</p></form>'); 530: } 531: } 532: 533: =pod 534: 535: =item Copy1($request, $user, $domain, $filename, $newfilename) 536: 537: Performs phase 1 processing of the construction space copy command. 538: Ensure that the source file exists. Ensure that a destination exists, 539: also warn if the destination already exists. 540: 541: Parameters: 542: 543: =over 4 544: 545: =item $request - Apache Request Object [in] request object for the current 546: request. 547: 548: =item $user - string [in] Name of the user initiating the request. 549: 550: =item $domain - string [in] Domain the initiating user is logged in as 551: 552: =item $fn - string [in] Source filename. 553: 554: =item $newfilename-string [in] Destination filename. 555: 556: =back 557: 558: =cut 559: 560: sub Copy1 { 561: my ($request, $user, $domain, $fn, $newfilename) = @_; 562: 563: if(-e $fn) { 564: # is dest a dir 565: if (-d $newfilename) { 566: if ($fn =~ m|/([^/]*)$|) { $newfilename .= '/'.$1; } 567: } 568: if ($newfilename =~ m|/[^\.]+$|) { 569: #no extension add on original extension 570: if ($fn =~ m|/[^\.]*\.([^\.]+)$|) { $newfilename.='.'.$1; } 571: } 572: $newfilename=~s://+:/:g; # remove duplicate / 573: while ($newfilename=~m:/\.\./:) { 574: $newfilename=~ s:/[^/]+/\.\./:/:g; #remove dir/.. 575: } 576: $request->print(&checksuffix($fn,$newfilename)); 577: my $return=&exists($user, $domain, $newfilename); 578: $request->print($return); 579: if ($return =~/^Error:/) { 580: $request->print('<br /><a href="'.&url($fn).'">'.&mt('Cancel').'</a>'); 581: return; 582: } 583: $request->print('<input type="hidden" name="newfilename" value="'. 584: $newfilename. 585: '" /><p>'.&mt('Copy').' '.&display($fn).'<br />to '. 586: &display($newfilename).'?</p>'); 587: &CloseForm1($request, $fn); 588: } else { 589: $request->print('<p>'.&mt('No such file').': '.&display($fn).'</p></form>'); 590: } 591: } 592: 593: =pod 594: 595: =item NewDir1 596: 597: Does all phase 1 processing of directory creation: 598: Ensures that the user provides a new directory name, 599: and that the directory does not already exist. 600: 601: Parameters: 602: 603: =over 4 604: 605: =item $request - Apache Request Object [in] - Server request object for the 606: current url. 607: 608: =item $username - Name of the user that is requesting the directory creation. 609: 610: =item $domain - Domain user is in 611: 612: =item $fn - source file. 613: 614: =item $newdir - Name of the directory to be created; path relative to the 615: top level of construction space. 616: =back 617: 618: Side Effects: 619: 620: =over 4 621: 622: =item A new form is displayed. Clicking on the confirmation button 623: causes the newdir operation to transition into phase 2. The hidden field 624: "newfilename" is set with the construction space path to the new directory. 625: 626: 627: =back 628: 629: =cut 630: 631: 632: sub NewDir1 { 633: my ($request, $username, $domain, $fn, $newfilename, $mode) = @_; 634: 635: my $result=&exists($username,$domain,$newfilename); 636: if ($result) { 637: $request->print('<font color="red">'.$result.'</font></form>'); 638: } else { 639: if ($mode eq 'testbank') { 640: $request->print('<input type="hidden" name="callingmode" value="testbank">'); 641: } elsif ($mode eq 'imsimport') { 642: $request->print('<input type="hidden" name="callingmode" value="imsimport">'); 643: } 644: $request->print('<input type="hidden" name="newfilename" value="'. 645: $newfilename.'" /><p>'.&mt('Make new directory').' '. 646: &display($newfilename).'?</p>'); 647: &CloseForm1($request, $fn); 648: } 649: } 650: 651: 652: sub Decompress1 { 653: my ($request, $user, $domain, $fn) = @_; 654: if( -e $fn) { 655: $request->print('<input type="hidden" name="newfilename" value="'.$fn.'"/>'); 656: $request->print('<p>'.&mt('Decompress').' '.&display($fn).'?</p>'); 657: &CloseForm1($request, $fn); 658: } else { 659: $request->print('<p>'.&mt('No such file').': '.&display($fn).'</p></form>'); 660: } 661: } 662: 663: =pod 664: 665: =item NewFile1 666: 667: Does all phase 1 processing of file creation: 668: Ensures that the user provides a new filename, adds proper extension 669: if needed and that the file does not already exist, if it is a html, 670: problem, page, or sequence, it then creates a form link to hand the 671: actual creation off to the proper handler. 672: 673: Parameters: 674: 675: =over 4 676: 677: =item $request - Apache Request Object [in] - Server request object for the 678: current url. 679: 680: =item $username - Name of the user that is requesting the directory creation. 681: 682: =item $domain - Name of the domain of the user 683: 684: =item $fn - Source file name 685: 686: =item $newfilename 687: - Name of the file to be created; no path information 688: =back 689: 690: Side Effects: 691: 692: =over 4 693: 694: =item 2 new forms are displayed. Clicking on the confirmation button 695: causes the browser to attempt to load the specfied URL, allowing the 696: proper handler to take care of file creation. There is also a Cancel 697: button which returns you to the driectory listing you came from 698: 699: =back 700: 701: =cut 702: 703: sub NewFile1 { 704: my ($request, $user, $domain, $fn, $newfilename) = @_; 705: 706: if ($ENV{'form.action'} =~ /new(.+)file/) { 707: my $extension=$1; 708: 709: ##Informs User (name).(number).(extension) not allowed 710: if($newfilename =~ /\.(\d+)\.(\w+)$/){ 711: $r->print('<font color="red">'.$newfilename. 712: ' - '.&mt('Bad Filename').'<br />('.&mt('name').').('.&mt('number').').('.&mt('extension').')'. 713: ' '.&mt('Not Allowed').'</font>'); 714: return; 715: } 716: if ($newfilename !~ /\Q.$extension\E$/) { 717: if ($newfilename =~ m|^[^\.]*\.([^\.]+)$|) { 718: #already has an extension strip it and add in expected one 719: $newfilename =~ s|.([^\.]+)$||; 720: } 721: $newfilename.=".$extension"; 722: } 723: } 724: my $result=&exists($user,$domain,$newfilename); 725: if($result) { 726: $request->print('<font color="red">'.$result.'</font></form>'); 727: } else { 728: $request->print('<p>'.&mt('Make new file').' '.&display($newfilename).'?</p>'); 729: $request->print('</form>'); 730: $request->print('<form action="'.&url($newfilename). 731: '" method="POST"><p><input type="submit" value="'.&mt('Continue').'" /></p></form>'); 732: $request->print('<form action="'.&url($fn). 733: '" method="POST"><p><input type="submit" value="'.&mt('Cancel').'" /></p></form>'); 734: } 735: } 736: 737: =pod 738: 739: =item phaseone($r, $fn, $uname, $udom) 740: 741: Peforms phase one processing of the request. In phase one, error messages 742: are returned if the request cannot be performed (e.g. attempts to manipulate 743: files that are nonexistent). If the operation can be performed, what is 744: about to be done will be presented to the user for confirmation. If the 745: user confirms the request, then phase two is executed, the action 746: performed and reported to the user. 747: 748: Parameters: 749: 750: =over 4 751: 752: =item $r - request object [in] - The Apache request being executed. 753: 754: =item $fn = string [in] - The filename being manipulated by the 755: request. 756: 757: =item $uname - string [in] Name of user logged in and doing this action. 758: 759: =item $udom - string [in] Domain name under which the user logged in. 760: 761: =back 762: 763: =cut 764: 765: sub phaseone { 766: my ($r,$fn,$uname,$udom)=@_; 767: 768: my $doingdir=0; 769: if ($ENV{'form.action'} eq 'newdir') { $doingdir=1; } 770: my $newfilename=&cleanDest($r,$ENV{'form.newfilename'},$doingdir,$fn); 771: $newfilename=&relativeDest($fn,$newfilename,$uname); 772: $r->print('<form action="/adm/cfile" method="post">'. 773: '<input type="hidden" name="qualifiedfilename" value="'.$fn.'" />'. 774: '<input type="hidden" name="phase" value="two" />'. 775: '<input type="hidden" name="action" value="'.$ENV{'form.action'}.'" />'); 776: 777: if ($ENV{'form.action'} eq 'rename') { 778: &Rename1($r, $uname, $udom, $fn, $newfilename, 'rename'); 779: } elsif ($ENV{'form.action'} eq 'move') { 780: &Rename1($r, $uname, $udom, $fn, $newfilename, 'move'); 781: } elsif ($ENV{'form.action'} eq 'delete') { 782: &Delete1($r, $uname, $udom, $fn); 783: } elsif ($ENV{'form.action'} eq 'decompress') { 784: &Decompress1($r, $uname, $udom, $fn); 785: } elsif ($ENV{'form.action'} eq 'copy') { 786: if($newfilename) { 787: &Copy1($r, $uname, $udom, $fn, $newfilename); 788: } else { 789: $r->print('<p>'.&mt('No new filename specified.').'</p></form>'); 790: } 791: } elsif ($ENV{'form.action'} eq 'newdir') { 792: my $mode = ''; 793: if (exists($ENV{'form.callingmode'}) ) { 794: $mode = $ENV{'form.callingmode'}; 795: } 796: &NewDir1($r, $uname, $udom, $fn, $newfilename, $mode); 797: } elsif ($ENV{'form.action'} eq 'newfile' || 798: $ENV{'form.action'} eq 'newhtmlfile' || 799: $ENV{'form.action'} eq 'newproblemfile' || 800: $ENV{'form.action'} eq 'newpagefile' || 801: $ENV{'form.action'} eq 'newsequencefile' || 802: $ENV{'form.action'} eq 'newrightsfile' || 803: $ENV{'form.action'} eq 'newstyfile' || 804: $ENV{'form.action'} eq 'Select Action') { 805: if ($newfilename) { 806: &NewFile1($r, $uname, $udom, $fn, $newfilename); 807: } else { 808: $r->print('<p>'.&mt('No new filename specified.').'</p></form>'); 809: } 810: } 811: } 812: 813: =pod 814: 815: =item Rename2($request, $user, $directory, $oldfile, $newfile) 816: 817: Performs phase 2 processing of a rename reequest. This is where the 818: actual rename is performed. 819: 820: Parameters 821: 822: =over 4 823: 824: =item $request - Apache request object [in] The request being processed. 825: 826: =item $user - string [in] The name of the user initiating the request. 827: 828: =item $directory - string [in] The name of the directory relative to the 829: construction space top level of the renamed file. 830: 831: =item $oldfile - Name of the file. 832: 833: =item $newfile - Name of the new file. 834: 835: =back 836: 837: Returns: 838: 839: =over 4 840: 841: =item 1 Success. 842: 843: =item 0 Failure. 844: 845: =cut 846: 847: sub Rename2 { 848: 849: my ($request, $user, $directory, $oldfile, $newfile) = @_; 850: 851: &Debug($request, "Rename2 directory: ".$directory." old file: ".$oldfile. 852: " new file ".$newfile."\n"); 853: &Debug($request, "Target is: ".$directory.'/'. 854: $newfile); 855: if (-e $oldfile) { 856: 857: my $oRN=$oldfile; 858: my $nRN=$newfile; 859: unless (rename($oldfile,$newfile)) { 860: $request->print('<font color="red">'.&mt('Error').': '.$!.'</font>'); 861: return 0; 862: } 863: ## If old name.(extension) exits, move under new name. 864: ## If it doesn't exist and a new.(extension) exists 865: ## delete it (only concern when renaming over files) 866: my $tmp1=$oRN.'.meta'; 867: my $tmp2=$nRN.'.meta'; 868: if(-e $tmp1){ 869: unless(rename($tmp1,$tmp2)){ } 870: } elsif(-e $tmp2){ 871: unlink $tmp2; 872: } 873: $tmp1=$oRN.'.save'; 874: $tmp2=$nRN.'.save'; 875: if(-e $tmp1){ 876: unless(rename($tmp1,$tmp2)){ } 877: } elsif(-e $tmp2){ 878: unlink $tmp2; 879: } 880: $tmp1=$oRN.'.log'; 881: $tmp2=$nRN.'.log'; 882: if(-e $tmp1){ 883: unless(rename($tmp1,$tmp2)){ } 884: } elsif(-e $tmp2){ 885: unlink $tmp2; 886: } 887: $tmp1=$oRN.'.bak'; 888: $tmp2=$nRN.'.bak'; 889: if(-e $tmp1){ 890: unless(rename($tmp1,$tmp2)){ } 891: } elsif(-e $tmp2){ 892: unlink $tmp2; 893: } 894: } else { 895: $request->print("<p> ".&mt('No such file').": ".&display($oldfile).'</p></form>'); 896: return 0; 897: } 898: return 1; 899: } 900: 901: =pod 902: 903: =item Delete2($request, $user, $filename) 904: 905: Performs phase two of a delete. The user has confirmed that they want 906: to delete the selected file. The file is deleted and the results of the 907: delete attempt are indicated. 908: 909: Parameters: 910: 911: =over 4 912: 913: =item $request - Apache Request object [in] the request object for the current 914: delete operation. 915: 916: =item $user - string [in] The name of the user initiating the delete 917: request. 918: 919: =item $filename - string [in] The name of the file, relative to construction 920: space, to delete. 921: 922: =back 923: 924: Returns: 925: 1 - success. 926: 0 - Failure. 927: 928: =cut 929: 930: sub Delete2 { 931: my ($request, $user, $filename) = @_; 932: if(opendir DIR, $filename) { 933: my @files=readdir(DIR); 934: shift @files; shift @files; # takes off . and .. 935: if(@files) { 936: $request->print('<font color="red"> '.&mt('Error: Directory Non Empty').'</font>'); 937: return 0; 938: } else { 939: if(-e $filename) { 940: unless(rmdir($filename)) { 941: $request->print('<font color="red">'.&mt('Error').': '.$!.'</font>'); 942: return 0; 943: } 944: } else { 945: $request->print('<p> '.&mt('No such file').'. </p></form>'); 946: return 0; 947: } 948: } 949: } else { 950: if(-e $filename) { 951: unless(unlink($filename)) { 952: $request->print('<font color="red">'.&mt('Error').': '.$!.'</font>'); 953: return 0; 954: } 955: } else { 956: $request->print('<p> '.&mt('No such file').'. </p></form>'); 957: return 0; 958: } 959: } 960: return 1; 961: } 962: 963: =pod 964: 965: =item Copy2($request, $username, $dir, $oldfile, $newfile) 966: 967: Performs phase 2 of a copy. The file is copied and the status 968: of that copy is reported back to the user. 969: 970: =over 4 971: 972: =item $request - Apache request object [in]; the apache request currently 973: being executed. 974: 975: =item $username - string [in] Name of the user who is requesting the copy. 976: 977: =item $dir - string [in] Directory path relative to the construction space 978: of the destination file. 979: 980: =item $oldfile - string [in] Name of the source file. 981: 982: =item $newfile - string [in] Name of the destination file. 983: 984: 985: =back 986: 987: Returns 0 failure, and 0 successs. 988: 989: =cut 990: 991: sub Copy2 { 992: my ($request, $username, $dir, $oldfile, $newfile) = @_; 993: &Debug($request ,"Will try to copy $oldfile to $newfile"); 994: if(-e $oldfile) { 995: unless (copy($oldfile, $newfile)) { 996: $request->print('<font color="red"> '.&mt('copy Error').': '.$!.'</font>'); 997: return 0; 998: } elsif (!chmod(0660, $newfile)) { 999: $request->print('<font color="red"> '.&mt('chmod error').': '.$!.'</font>'); 1000: return 0; 1001: } elsif (-e $oldfile.'.meta' && 1002: !copy($oldfile.'.meta', $newfile.'.meta') && 1003: !chmod(0660, $newfile.'.meta')) { 1004: $request->print('<font color="red"> '.&mt('copy metadata error'). 1005: ': '.$!.'</font>'); 1006: return 0; 1007: } else { 1008: return 1; 1009: } 1010: } else { 1011: $request->print('<p> '.&mt('No such file').' </p>'); 1012: return 0; 1013: } 1014: return 1; 1015: } 1016: 1017: =pod 1018: 1019: =item NewDir2($request, $user, $newdirectory) 1020: 1021: Performs phase 2 processing of directory creation. This involves creating the directory and 1022: reporting the results of that creation to the user. 1023: 1024: Parameters: 1025: =over 4 1026: 1027: =item $request - Apache request object [in]. Object representing the current HTTP request. 1028: 1029: =item $user - string [in] The name of the user that is initiating the request. 1030: 1031: =item $newdirectory - string [in] The full path of the directory being created. 1032: 1033: =back 1034: 1035: Returns 0 - failure 1 - success. 1036: 1037: =cut 1038: 1039: sub NewDir2 { 1040: my ($request, $user, $newdirectory) = @_; 1041: 1042: unless(mkdir($newdirectory, 02770)) { 1043: $request->print('<font color="red">'.&mt('Error').': '.$!.'</font>'); 1044: return 0; 1045: } 1046: unless(chmod(02770, ($newdirectory))) { 1047: $request->print('<font color="red"> '.&mt('Error').': '.$!.'</font>'); 1048: return 0; 1049: } 1050: return 1; 1051: } 1052: 1053: sub decompress2 { 1054: my ($r, $user, $dir, $file) = @_; 1055: &Apache::lonnet::appenv('cgi.file' => $file); 1056: &Apache::lonnet::appenv('cgi.dir' => $dir); 1057: my $result=&Apache::lonnet::ssi_body('/cgi-bin/decompress.pl'); 1058: $r->print($result); 1059: &Apache::lonnet::delenv('cgi.file'); 1060: &Apache::lonnet::delenv('cgi.dir'); 1061: return 1; 1062: } 1063: 1064: =pod 1065: 1066: =item phasetwo($r, $fn, $uname, $udom) 1067: 1068: Controls the phase 2 processing of file management 1069: requests for construction space. In phase one, the user 1070: was asked to confirm the operation. In phase 2, the operation 1071: is performed and the result is shown. 1072: 1073: The strategy is to break out the processing into specific action processors 1074: named action2 where action is the requested action and the 2 denotes 1075: phase 2 processing. 1076: 1077: Parameters: 1078: 1079: =over 4 1080: 1081: =item $r - Apache Request object [in] The request object for this httpd 1082: transaction. 1083: 1084: =item $fn - string [in] A filename indicating the object that is being 1085: manipulated. 1086: 1087: =item $uname - string [in] The name of the user initiating the file management 1088: request. 1089: 1090: =item $udom - string [in] The login domain of the user initiating the 1091: file management request. 1092: =back 1093: 1094: =cut 1095: 1096: sub phasetwo { 1097: my ($r,$fn,$uname,$udom)=@_; 1098: 1099: &Debug($r, "loncfile - Entering phase 2 for $fn"); 1100: 1101: # Break down the file into it's component pieces. 1102: 1103: my $dir; # Directory path 1104: my $main; # Filename. 1105: my $suffix; # Extension. 1106: if ($fn=~m:(.*)/([^/]+):) { 1107: $dir=$1; # Directory path 1108: $main=$2; # Filename. 1109: } 1110: if($main=~m:\.(\w+)$:){ # Fixes problems with filenames with no extensions 1111: $main=$`; #This is what is before the match (.) so it's just the main filename, yea it's nasty 1112: $suffix=$1; #This is the actually filename extension if it exists 1113: } 1114: my $dest; # On success this is where we'll go. 1115: 1116: &Debug($r,"loncfile::phase2 dir = $dir main = $main suffix = $suffix"); 1117: &Debug($r," newfilename = ".$ENV{'form.newfilename'}); 1118: 1119: my $conspace=$fn; 1120: 1121: &Debug($r,"loncfile::phase2 Full construction space name: $conspace"); 1122: 1123: &Debug($r,"loncfie::phase2 action is $ENV{'form.action'}"); 1124: 1125: # Select the appropriate processing sub. 1126: if ($ENV{'form.action'} eq 'decompress') { 1127: $main .= '.'; 1128: $main .= $suffix; 1129: if(!&decompress2($r, $uname, $dir, $main)) { 1130: return ; 1131: } 1132: $dest = $dir."/."; 1133: } elsif ($ENV{'form.action'} eq 'rename' || 1134: $ENV{'form.action'} eq 'move') { 1135: if($ENV{'form.newfilename'}) { 1136: if (!defined($dir)) { 1137: $fn=~m:^(.*)/:; 1138: $dir=$1; 1139: } 1140: if(!&Rename2($r, $uname, $dir, $fn, $ENV{'form.newfilename'})) { 1141: return; 1142: } 1143: $dest = $ENV{'form.newfilename'}; 1144: } 1145: } elsif ($ENV{'form.action'} eq 'delete') { 1146: if(!&Delete2($r, $uname, $ENV{'form.newfilename'})) { 1147: return ; 1148: } 1149: # Once a resource is deleted, we just list the directory that 1150: # previously held it. 1151: # 1152: $dest = $dir."/."; # Parent dir. 1153: } elsif ($ENV{'form.action'} eq 'copy') { 1154: if($ENV{'form.newfilename'}) { 1155: if(!&Copy2($r, $uname, $dir, $fn, $ENV{'form.newfilename'})) { 1156: return ; 1157: } 1158: $dest = $ENV{'form.newfilename'}; 1159: } else { 1160: $r->print('<p>'.&mt('No New filename specified').'</p></form>'); 1161: return; 1162: } 1163: 1164: } elsif ($ENV{'form.action'} eq 'newdir') { 1165: my $newdir= $ENV{'form.newfilename'}; 1166: if(!&NewDir2($r, $uname, $newdir)) { 1167: return; 1168: } 1169: $dest = $newdir."/"; 1170: } 1171: if ( ($ENV{'form.action'} eq 'newdir') && ($ENV{'form.phase'} eq 'two') && ( ($ENV{'form.callingmode'} eq 'testbank') || ($ENV{'form.callingmode'} eq 'imsimport') ) ) { 1172: $r->print('<h3><a href="javascript:self.close()">'.&mt('Done').'</a></h3>'); 1173: } else { 1174: $r->print('<h3><a href="'.&url($dest).'">'.&mt('Done').'</a></h3>'); 1175: } 1176: } 1177: 1178: sub handler { 1179: 1180: $r=shift; 1181: 1182: &Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'},['decompress','action','filename','newfilename']); 1183: 1184: &Debug($r, "loncfile.pm - handler entered"); 1185: &Debug($r, " filename: ".$ENV{'form.filename'}); 1186: &Debug($r, " newfilename: ".$ENV{'form.newfilename'}); 1187: # 1188: # Determine the root filename 1189: # This could come in as "filename", which actually is a URL, or 1190: # as "qualifiedfilename", which is indeed a real filename in filesystem 1191: # 1192: my $fn; 1193: 1194: if ($ENV{'form.filename'}) { 1195: &Debug($r, "test: $ENV{'form.filename'}"); 1196: $fn=&Apache::lonnet::unescape($ENV{'form.filename'}); 1197: $fn=&URLToPath($fn); 1198: } elsif($ENV{'QUERY_STRING'} && $ENV{'form.phase'} ne 'two') { 1199: #Just hijack the script only the first time around to inject the 1200: #correct information for further processing 1201: $fn=&Apache::lonnet::unescape($ENV{'form.decompress'}); 1202: $fn=&URLToPath($fn); 1203: $ENV{'form.action'}="decompress"; 1204: } elsif ($ENV{'form.qualifiedfilename'}) { 1205: $fn=$ENV{'form.qualifiedfilename'}; 1206: } else { 1207: &Debug($r, "loncfile::handler - no form.filename"); 1208: $r->log_reason($ENV{'user.name'}.' at '.$ENV{'user.domain'}. 1209: ' unspecified filename for cfile', $r->filename); 1210: return HTTP_NOT_FOUND; 1211: } 1212: 1213: unless ($fn) { 1214: &Debug($r, "loncfile::handler - doctored url is empty"); 1215: $r->log_reason($ENV{'user.name'}.' at '.$ENV{'user.domain'}. 1216: ' trying to cfile non-existing file', $r->filename); 1217: return HTTP_NOT_FOUND; 1218: } 1219: 1220: # ----------------------------------------------------------- Start page output 1221: my $uname; 1222: my $udom; 1223: 1224: ($uname,$udom)= 1225: &Apache::loncacc::constructaccess($fn,$r->dir_config('lonDefDomain')); 1226: &Debug($r, 1227: "loncfile::handler constructaccess uname = $uname domain = $udom"); 1228: unless (($uname) && ($udom)) { 1229: $r->log_reason($uname.' at '.$udom. 1230: ' trying to manipulate file '.$ENV{'form.filename'}. 1231: ' ('.$fn.') - not authorized', 1232: $r->filename); 1233: return HTTP_NOT_ACCEPTABLE; 1234: } 1235: 1236: 1237: &Apache::loncommon::content_type($r,'text/html'); 1238: $r->send_http_header; 1239: 1240: if ( ($ENV{'form.action'} eq 'newdir') && ($ENV{'form.phase'} eq 'two') && ( ($ENV{'form.callingmode'} eq 'testbank') || ($ENV{'form.callingmode'} eq 'imsimport') ) ) { 1241: my $newdirname = $ENV{'form.newfilename'}; 1242: $r->print('<html><head><title>LON-CAPA Construction Space</title><script language="Javascript">'); 1243: $r->print(qq| 1244: function writeDone() { 1245: var winName = window.opener 1246: window.focus(); 1247: winName.document.dataForm.newdir.value = "$newdirname" 1248: setTimeout("self.close()",10000) 1249: } 1250: </script> 1251: </head>|); 1252: my $loaditem = 'onLoad="writeDone()"'; 1253: $r->print(&Apache::loncommon::bodytag('Construction Space File Operation','',$loaditem)); 1254: } else { 1255: $r->print('<html><head><title>LON-CAPA Construction Space</title></head>'); 1256: $r->print(&Apache::loncommon::bodytag('Construction Space File Operation')); 1257: } 1258: 1259: 1260: $r->print('<h3>'.&mt('Location').': '.&display($fn).'</h3>'); 1261: 1262: if (($uname ne $ENV{'user.name'}) || ($udom ne $ENV{'user.domain'})) { 1263: $r->print('<h3><font color="red">'.&mt('Co-Author').': '.$uname.' at '.$udom. 1264: '</font></h3>'); 1265: } 1266: 1267: 1268: &Debug($r, "loncfile::handler Form action is $ENV{'form.action'} "); 1269: if ($ENV{'form.action'} eq 'delete') { 1270: $r->print('<h3>'.&mt('Delete').'</h3>'); 1271: } elsif ($ENV{'form.action'} eq 'rename') { 1272: $r->print('<h3>'.&mt('Rename').'</h3>'); 1273: } elsif ($ENV{'form.action'} eq 'move') { 1274: $r->print('<h3>'.&mt('Move').'</h3>'); 1275: } elsif ($ENV{'form.action'} eq 'newdir') { 1276: $r->print('<h3>'.&mt('New Directory').'</h3>'); 1277: } elsif ($ENV{'form.action'} eq 'decompress') { 1278: $r->print('<h3>'.&mt('Decompress').'</h3>'); 1279: } elsif ($ENV{'form.action'} eq 'copy') { 1280: $r->print('<h3>'.&mt('Copy').'</h3>'); 1281: } elsif ($ENV{'form.action'} eq 'newfile' || 1282: $ENV{'form.action'} eq 'newhtmlfile' || 1283: $ENV{'form.action'} eq 'newproblemfile' || 1284: $ENV{'form.action'} eq 'newpagefile' || 1285: $ENV{'form.action'} eq 'newsequencefile' || 1286: $ENV{'form.action'} eq 'newrightsfile' || 1287: $ENV{'form.action'} eq 'newstyfile' || 1288: $ENV{'form.action'} eq 'Select Action' ) { 1289: $r->print('<h3>'.&mt('New Resource').'</h3>'); 1290: } else { 1291: $r->print('<p>'.&mt('Unknown Action').' '.$ENV{'form.action'}.' </p></body></html>'); 1292: return OK; 1293: } 1294: if ($ENV{'form.phase'} eq 'two') { 1295: &Debug($r, "loncfile::handler entering phase2"); 1296: &phasetwo($r,$fn,$uname,$udom); 1297: } else { 1298: &Debug($r, "loncfile::handler entering phase1"); 1299: &phaseone($r,$fn,$uname,$udom); 1300: } 1301: 1302: $r->print('</body></html>'); 1303: return OK; 1304: } 1305: 1306: 1; 1307: __END__ 1308: