[79011] branches/gsoc11-post-destroot/base/src/port1.0/portpostdestroot.tcl

[fotanus at macports.org]

Revision: 79011
          http://trac.macports.org/changeset/79011
Author:   fotanus at macports.org
Date:     2011-05-29 19:58:38 -0700 (Sun, 29 May 2011)
Log Message:
-----------
Added check for symlinks to post-destroot.

Modified Paths:
--------------
    branches/gsoc11-post-destroot/base/src/port1.0/portpostdestroot.tcl

Modified: branches/gsoc11-post-destroot/base/src/port1.0/portpostdestroot.tcl
===================================================================
--- branches/gsoc11-post-destroot/base/src/port1.0/portpostdestroot.tcl	2011-05-30 00:13:58 UTC (rev 79010)
+++ branches/gsoc11-post-destroot/base/src/port1.0/portpostdestroot.tcl	2011-05-30 02:58:38 UTC (rev 79011)
@@ -13,9 +13,51 @@
 
 set_ui_prefix
 
+# list all links on a directory recursively
+proc portpostdestroot::links_list {dir} {
+    set ret {}
+    foreach item [glob -nocomplain -type {d l} -directory $dir *] {
+        if {[file isdirectory $item]} {
+            set ret [concat $ret [links_list $item]]
+        } else {
+            #is link
+            lappend ret $item
+        }
+    }
+    return $ret
+}
+
+proc portpostdestroot::postdestroot_symlink_check {} {
+    global UI_PREFIX destroot prefix
+    ui_notice "$UI_PREFIX Checking for links"
+    foreach link [links_list $destroot] {
+        set points_to [file link $link]
+        if { [string compare [file pathtype $points_to] {absolute}] == 0 } {
+            if {[regexp $destroot $points_to]} {
+                ui_debug "Absolute link path poiting to inside of destroot"
+                return -code error "Absolute link path poiting to inside of destroot"
+            } else {
+                ui_debug "Absolute link path poiting to outside of destroot"
+            }
+        } elseif { [string compare [file pathtype $points_to] {relative}] == 0 } {
+            regsub $destroot$prefix/ $link "" link_without_destroot
+            set dir_depth [regexp -all / $link_without_destroot]
+            set return_depth [regsub -all {\.\./} $points_to "" points_to_without_returns]
+            set return_delta [expr $return_depth - [regexp -all / $points_to_without_returns]]
+            if { $return_delta < $dir_depth } {
+                ui_debug "Relative link path poiting to inside of destroot"
+            } else {
+                ui_debug "Relative link path poiting to outside of destroot"
+                return -code error "Relative link path poiting to outside of destroot"
+            }
+        }
+    }
+}
+
 proc portpostdestroot::postdestroot_main {args} {
     global UI_PREFIX
     ui_notice "$UI_PREFIX Executing post-destroot phase"
+    postdestroot_symlink_check
     return 0
 }
 
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://lists.macosforge.org/pipermail/macports-changes/attachments/20110529/16a7c336/attachment.html>