Changeset 62701


Ignore:
Timestamp:
Jan 14, 2010, 2:45:27 AM (10 years ago)
Author:
jmr@…
Message:

portuninstall.tcl, portimage.tcl: whitespace and modelines

Location:
trunk/base/src/registry1.0
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • trunk/base/src/registry1.0/portimage.tcl

    r62631 r62701  
     1# -*- coding: utf-8; mode: tcl; tab-width: 4; indent-tabs-mode: nil; c-basic-offset: 4 -*- vim:fenc=utf-8:ft=tcl:et:sw=4:ts=4:sts=4
    12# portimage.tcl
    23# $Id$
     
    4445# They allow the user to install multiple versions of the same port, treating
    4546# each revision and each different combination of variants as a "version".
    46 # 
     47#
    4748# From there, the user can "activate" a port image.  This creates {sym,hard}links for
    48 # all files in the image into the ${prefix}.  Directories are created. 
     49# all files in the image into the ${prefix}.  Directories are created.
    4950# Activation checks the registry's file_map for any files which conflict with
    5051# other "active" ports, and will not overwrite the links to the those files.
     
    5253#
    5354# The user can also "deactivate" an active port.  This will remove all {sym,hard}links
    54 # from ${prefix}, and if any directories are empty, remove them as well.  It 
    55 # will also remove all of the references of the files from the registry's 
     55# from ${prefix}, and if any directories are empty, remove them as well.  It
     56# will also remove all of the references of the files from the registry's
    5657# file_map
    5758#
     
    6465variable force
    6566namespace export force
    66        
    67 # Activate a "Port Image"       
     67
     68# Activate a "Port Image"
    6869proc activate {name v optionslist} {
    69         global macports::prefix macports::registry.path UI_PREFIX
    70         array set options $optionslist
    71         variable force
    72 
    73         if {[info exists options(ports_force)] && [string equal -nocase $options(ports_force) "yes"] } {
    74                 set force 1
    75         } else {
    76                 set force 0
    77         }
    78 
    79         set ilist [_check_registry $name $v]
    80         # set name again since the one we were passed may not have had the correct case
    81         set name [lindex $ilist 0]
    82         set version [lindex $ilist 1]
    83         set revision [lindex $ilist 2]
    84         set     variants [lindex $ilist 3]
    85 
    86         # if another version of this port is active, deactivate it first
    87         set ilist [registry::installed $name]
    88         if { [llength $ilist] > 1 } {
    89                 foreach i $ilist {
    90                         set iname [lindex $i 0]
    91                         set iversion [lindex $i 1]
    92                         set irevision [lindex $i 2]
    93                         set     ivariants [lindex $i 3]
    94                         set iactive [lindex $i 4]
    95                         if { ![string equal ${iversion}_${irevision}${ivariants} ${version}_${revision}${variants}] && $iactive == 1 } {
    96                                 deactivate $iname ${iversion}_${irevision}${ivariants} $optionslist
    97                         }
    98                 }
    99         }
    100        
     70    global macports::prefix macports::registry.path UI_PREFIX
     71    array set options $optionslist
     72    variable force
     73
     74    if {[info exists options(ports_force)] && [string equal -nocase $options(ports_force) "yes"] } {
     75        set force 1
     76    } else {
     77        set force 0
     78    }
     79
     80    set ilist [_check_registry $name $v]
     81    # set name again since the one we were passed may not have had the correct case
     82    set name [lindex $ilist 0]
     83    set version [lindex $ilist 1]
     84    set revision [lindex $ilist 2]
     85    set variants [lindex $ilist 3]
     86
     87    # if another version of this port is active, deactivate it first
     88    set ilist [registry::installed $name]
     89    if { [llength $ilist] > 1 } {
     90        foreach i $ilist {
     91            set iname [lindex $i 0]
     92            set iversion [lindex $i 1]
     93            set irevision [lindex $i 2]
     94            set ivariants [lindex $i 3]
     95            set iactive [lindex $i 4]
     96            if { ![string equal ${iversion}_${irevision}${ivariants} ${version}_${revision}${variants}] && $iactive == 1 } {
     97                deactivate $iname ${iversion}_${irevision}${ivariants} $optionslist
     98            }
     99        }
     100    }
     101
    101102    if {$v != ""} {
    102103        ui_msg "$UI_PREFIX [format [msgcat::mc "Activating %s @%s"] $name $v]"
     
    105106    }
    106107
    107         set ref [registry::open_entry $name $version $revision $variants]
    108        
    109         if { ![string equal [registry::property_retrieve $ref installtype] "image"] } {
    110                 return -code error "Image error: ${name} @${version}_${revision}${variants} not installed as an image."
    111         }
    112         if { [registry::property_retrieve $ref active] != 0 } {
    113                 return -code error "Image error: ${name} @${version}_${revision}${variants} is already active."
    114         }
    115 
    116         set imagedir [registry::property_retrieve $ref imagedir]
    117 
    118         set contents [registry::property_retrieve $ref contents]
    119        
    120         set imagefiles [_check_contents $name $contents $imagedir]
    121        
    122         registry::open_file_map
    123         _activate_contents $name $imagefiles $imagedir
    124 
    125         registry::property_store $ref active 1
    126 
    127         registry::write_entry $ref
    128 
    129         foreach file $imagefiles {
    130                 registry::register_file $file $name
    131         }
    132         registry::write_file_map
    133         registry::close_file_map
     108    set ref [registry::open_entry $name $version $revision $variants]
     109
     110    if { ![string equal [registry::property_retrieve $ref installtype] "image"] } {
     111        return -code error "Image error: ${name} @${version}_${revision}${variants} not installed as an image."
     112    }
     113    if { [registry::property_retrieve $ref active] != 0 } {
     114        return -code error "Image error: ${name} @${version}_${revision}${variants} is already active."
     115    }
     116
     117    set imagedir [registry::property_retrieve $ref imagedir]
     118
     119    set contents [registry::property_retrieve $ref contents]
     120
     121    set imagefiles [_check_contents $name $contents $imagedir]
     122
     123    registry::open_file_map
     124    _activate_contents $name $imagefiles $imagedir
     125
     126    registry::property_store $ref active 1
     127
     128    registry::write_entry $ref
     129
     130    foreach file $imagefiles {
     131        registry::register_file $file $name
     132    }
     133    registry::write_file_map
     134    registry::close_file_map
    134135}
    135136
    136137proc deactivate {name v optionslist} {
    137         global UI_PREFIX
    138         array set options $optionslist
    139         variable force
    140 
    141         if {[info exists options(ports_force)] && [string equal -nocase $options(ports_force) "yes"] } {
    142                 set force 1
    143         } else {
    144                 set force 0
    145         }
    146 
    147         set ilist [registry::active $name]
    148         if { [llength $ilist] > 1 } {
    149                 return -code error "Registry error: Please specify the name of the port."
    150         } else {
    151                 set ilist [lindex $ilist 0]
    152         }
    153         # set name again since the one we were passed may not have had the correct case
    154         set name [lindex $ilist 0]
    155         set version [lindex $ilist 1]
    156         set revision [lindex $ilist 2]
    157         set     variants [lindex $ilist 3]
    158         set fqversion ${version}_${revision}${variants}
    159        
     138    global UI_PREFIX
     139    array set options $optionslist
     140    variable force
     141
     142    if {[info exists options(ports_force)] && [string equal -nocase $options(ports_force) "yes"] } {
     143        set force 1
     144    } else {
     145        set force 0
     146    }
     147
     148    set ilist [registry::active $name]
     149    if { [llength $ilist] > 1 } {
     150        return -code error "Registry error: Please specify the name of the port."
     151    } else {
     152        set ilist [lindex $ilist 0]
     153    }
     154    # set name again since the one we were passed may not have had the correct case
     155    set name [lindex $ilist 0]
     156    set version [lindex $ilist 1]
     157    set revision [lindex $ilist 2]
     158    set variants [lindex $ilist 3]
     159    set fqversion ${version}_${revision}${variants}
     160
    160161    if {$v != ""} {
    161162        ui_msg "$UI_PREFIX [format [msgcat::mc "Deactivating %s @%s"] $name $v]"
     
    163164        ui_msg "$UI_PREFIX [format [msgcat::mc "Deactivating %s"] $name]"
    164165    }
    165        
    166         if { $v != "" && ![string equal ${fqversion} $v] } {
    167                 return -code error "Active version of $name is not $v but ${fqversion}."
    168         }
    169        
    170         set ref [registry::open_entry $name $version $revision $variants]
    171 
    172         if { ![string equal [registry::property_retrieve $ref installtype] "image"] } {
    173                 return -code error "Image error: ${name} @${fqversion} not installed as an image."
    174         }
    175         if { [registry::property_retrieve $ref active] != 1 } {
    176                 return -code error "Image error: ${name} @${fqversion} is not active."
    177         }
    178 
    179         set imagedir [registry::property_retrieve $ref imagedir]
    180 
    181         registry::open_file_map
    182         set imagefiles [registry::port_registered $name]
    183 
    184         _deactivate_contents $name $imagefiles
    185 
    186         foreach file $imagefiles {
    187                 registry::unregister_file $file
    188         }
    189         registry::write_file_map
    190         registry::close_file_map
    191        
    192         registry::property_store $ref active 0
    193 
    194         registry::write_entry $ref
     166
     167    if { $v != "" && ![string equal ${fqversion} $v] } {
     168        return -code error "Active version of $name is not $v but ${fqversion}."
     169    }
     170
     171    set ref [registry::open_entry $name $version $revision $variants]
     172
     173    if { ![string equal [registry::property_retrieve $ref installtype] "image"] } {
     174        return -code error "Image error: ${name} @${fqversion} not installed as an image."
     175    }
     176    if { [registry::property_retrieve $ref active] != 1 } {
     177        return -code error "Image error: ${name} @${fqversion} is not active."
     178    }
     179
     180    set imagedir [registry::property_retrieve $ref imagedir]
     181
     182    registry::open_file_map
     183    set imagefiles [registry::port_registered $name]
     184
     185    _deactivate_contents $name $imagefiles
     186
     187    foreach file $imagefiles {
     188        registry::unregister_file $file
     189    }
     190    registry::write_file_map
     191    registry::close_file_map
     192
     193    registry::property_store $ref active 0
     194
     195    registry::write_entry $ref
    195196
    196197}
    197198
    198199proc _check_registry {name v} {
    199         global UI_PREFIX
    200 
    201         set ilist [registry::installed $name $v]
    202         if { [string equal $v ""] } {
    203                 if { [llength $ilist] > 1 } {
    204                     # set name again since the one we were passed may not have had the correct case
    205                     set name [lindex [lindex $ilist 0] 0]
    206                         ui_msg "$UI_PREFIX [msgcat::mc "The following versions of $name are currently installed:"]"
    207                         foreach i $ilist {
    208                                 set iname [lindex $i 0]
    209                                 set iversion [lindex $i 1]
    210                                 set irevision [lindex $i 2]
    211                                 set     ivariants [lindex $i 3]
    212                                 set iactive [lindex $i 4]
    213                                 if { $iactive == 0 } {
    214                                         ui_msg "$UI_PREFIX [format [msgcat::mc "        %s @%s_%s%s"] $iname $iversion $irevision $ivariants]"
    215                                 } elseif { $iactive == 1 } {
    216                                         ui_msg "$UI_PREFIX [format [msgcat::mc "        %s @%s_%s%s (active)"] $iname $iversion $irevision $ivariants]"
    217                                 }
    218                         }
    219                         return -code error "Registry error: Please specify the full version as recorded in the port registry."
    220                 } else {
    221                         return [lindex $ilist 0]
    222                 }
    223         } else {
    224                         return [lindex $ilist 0]
    225         }
    226         return -code error "Registry error: No port of $name installed."
     200    global UI_PREFIX
     201
     202    set ilist [registry::installed $name $v]
     203    if { [string equal $v ""] } {
     204        if { [llength $ilist] > 1 } {
     205            # set name again since the one we were passed may not have had the correct case
     206            set name [lindex [lindex $ilist 0] 0]
     207            ui_msg "$UI_PREFIX [msgcat::mc "The following versions of $name are currently installed:"]"
     208            foreach i $ilist {
     209                set iname [lindex $i 0]
     210                set iversion [lindex $i 1]
     211                set irevision [lindex $i 2]
     212                set ivariants [lindex $i 3]
     213                set iactive [lindex $i 4]
     214                if { $iactive == 0 } {
     215                    ui_msg "$UI_PREFIX [format [msgcat::mc "    %s @%s_%s%s"] $iname $iversion $irevision $ivariants]"
     216                } elseif { $iactive == 1 } {
     217                    ui_msg "$UI_PREFIX [format [msgcat::mc "    %s @%s_%s%s (active)"] $iname $iversion $irevision $ivariants]"
     218                }
     219            }
     220            return -code error "Registry error: Please specify the full version as recorded in the port registry."
     221        } else {
     222            return [lindex $ilist 0]
     223        }
     224    } else {
     225            return [lindex $ilist 0]
     226    }
     227    return -code error "Registry error: No port of $name installed."
    227228}
    228229
    229230proc _check_contents {name contents imagedir} {
    230         variable force
    231 
    232         set imagefiles [list]
    233 
    234         # This is big and hairy and probably could be done better.
    235         # First, we need to check the source file, make sure it exists
    236         # Then we remove the $imagedir from the path of the file in the contents
    237         #  list  and check to see if that file exists
    238         # Last, if the file exists, and belongs to another port, and force is set
    239         #  we remove the file from the file_map, take ownership of it, and
    240         #  clobber it
    241         foreach fe $contents {
    242                 if { ![file isdirectory [lindex $fe 0]] || [file type [lindex $fe 0]] == "link" } {
    243                         set srcfile [lindex $fe 0]
    244                         set file [string range [lindex $fe 0] [string length $imagedir] [string length [lindex $fe 0]]]
    245 
    246                         if { ![string equal $srcfile ""] } {
    247                                 lappend imagefiles $file
    248                         }
    249                 }
    250         }
    251 
    252         return $imagefiles
     231    variable force
     232
     233    set imagefiles [list]
     234
     235    # This is big and hairy and probably could be done better.
     236    # First, we need to check the source file, make sure it exists
     237    # Then we remove the $imagedir from the path of the file in the contents
     238    #  list  and check to see if that file exists
     239    # Last, if the file exists, and belongs to another port, and force is set
     240    #  we remove the file from the file_map, take ownership of it, and
     241    #  clobber it
     242    foreach fe $contents {
     243        if { ![file isdirectory [lindex $fe 0]] || [file type [lindex $fe 0]] == "link" } {
     244            set srcfile [lindex $fe 0]
     245            set file [string range [lindex $fe 0] [string length $imagedir] [string length [lindex $fe 0]]]
     246
     247            if { ![string equal $srcfile ""] } {
     248                lappend imagefiles $file
     249            }
     250        }
     251    }
     252
     253    return $imagefiles
    253254}
    254255
    255256proc _activate_file {srcfile dstfile} {
    256         # Don't recursively copy directories
    257         if { [file isdirectory $srcfile] && [file type $srcfile] != "link" } {
    258                 # Don't do anything if the directory already exists.
    259                 if { ![file isdirectory $dstfile] } {
    260                         file mkdir $dstfile
    261                         # fix attributes on the directory.
    262                         eval file attributes {$dstfile} [file attributes $srcfile]
    263                         # set mtime on installed element
    264                         file mtime $dstfile [file mtime $srcfile]
    265                 }
    266         } elseif { [file type $srcfile] == "link" } {
    267                 file copy -force -- $srcfile $dstfile
    268         } else {
    269                 # Try a hard link first and if that fails, a symlink
    270                 if {[catch {file link -hard $dstfile $srcfile}]} {
    271                         ui_debug "hardlinking $srcfile to $dstfile failed, symlinking instead"
    272                         file link -symbolic $dstfile $srcfile
    273                 }
    274         }
     257    # Don't recursively copy directories
     258    if { [file isdirectory $srcfile] && [file type $srcfile] != "link" } {
     259        # Don't do anything if the directory already exists.
     260        if { ![file isdirectory $dstfile] } {
     261            file mkdir $dstfile
     262            # fix attributes on the directory.
     263            eval file attributes {$dstfile} [file attributes $srcfile]
     264            # set mtime on installed element
     265            file mtime $dstfile [file mtime $srcfile]
     266        }
     267    } elseif { [file type $srcfile] == "link" } {
     268        file copy -force -- $srcfile $dstfile
     269    } else {
     270        # Try a hard link first and if that fails, a symlink
     271        if {[catch {file link -hard $dstfile $srcfile}]} {
     272            ui_debug "hardlinking $srcfile to $dstfile failed, symlinking instead"
     273            file link -symbolic $dstfile $srcfile
     274        }
     275    }
    275276}
    276277
    277278proc _activate_list {flist imagedir} {
    278         foreach file $flist {
    279                 if { [file type ${imagedir}${file}] == "link" } {
    280                         ui_debug "activating link: $file"
    281                 } elseif { [file isdirectory ${imagedir}${file}] } {
    282                         ui_debug "activating directory: $file"
    283                 } else {
    284                         ui_debug "activating file: $file"
    285                 }
    286                 _activate_file ${imagedir}${file} $file
    287         }
     279    foreach file $flist {
     280        if { [file type ${imagedir}${file}] == "link" } {
     281            ui_debug "activating link: $file"
     282        } elseif { [file isdirectory ${imagedir}${file}] } {
     283            ui_debug "activating directory: $file"
     284        } else {
     285            ui_debug "activating file: $file"
     286        }
     287        _activate_file ${imagedir}${file} $file
     288    }
    288289}
    289290
    290291proc _activate_contents {name imagefiles imagedir} {
    291         variable force
    292         global macports::prefix
    293 
    294         set files [list]
    295         set timestamp [clock seconds]
    296        
    297         # This is big and hairy and probably could be done better.
    298         # First, we need to check the source file, make sure it exists
    299         # Then we remove the $imagedir from the path of the file in the contents
    300         #  list  and check to see if that file exists
    301         # Last, if the file exists, and belongs to another port, and force is set
    302         #  we remove the file from the file_map, take ownership of it, and
    303         #  clobber it
    304         foreach file $imagefiles {
    305                 set srcfile ${imagedir}${file}
    306 
    307                 # To be able to install links, we test if we can lstat the file to figure
    308                 # out if the source file exists (file exists will return false for symlinks on
    309                 # files that do not exist)
    310                 if { [catch {file lstat $srcfile dummystatvar}] } {
    311                         return -code error "Image error: Source file $srcfile does not appear to exist (cannot lstat it).  Unable to activate port $name."
    312                 }
    313 
    314                 set port [registry::file_registered $file]
     292    variable force
     293    global macports::prefix
     294
     295    set files [list]
     296    set timestamp [clock seconds]
     297
     298    # This is big and hairy and probably could be done better.
     299    # First, we need to check the source file, make sure it exists
     300    # Then we remove the $imagedir from the path of the file in the contents
     301    #  list  and check to see if that file exists
     302    # Last, if the file exists, and belongs to another port, and force is set
     303    #  we remove the file from the file_map, take ownership of it, and
     304    #  clobber it
     305    foreach file $imagefiles {
     306        set srcfile ${imagedir}${file}
     307
     308        # To be able to install links, we test if we can lstat the file to figure
     309        # out if the source file exists (file exists will return false for symlinks on
     310        # files that do not exist)
     311        if { [catch {file lstat $srcfile dummystatvar}] } {
     312            return -code error "Image error: Source file $srcfile does not appear to exist (cannot lstat it).  Unable to activate port $name."
     313        }
     314
     315        set port [registry::file_registered $file]
    315316
    316317        if { $port != 0  && $force != 1 && $port != $name } {
     
    326327                return -code error "Image error: $file is being used by the active $port port.  Please deactivate this port first, or use 'port -f activate $name' to force the activation."
    327328            }
    328                 } elseif { [file exists $file] && $force != 1 } {
    329                         return -code error "Image error: $file already exists and does not belong to a registered port.  Unable to activate port $name."
    330                 } elseif { $force == 1 && [file exists $file] || $port != 0 } {
    331                         set bakfile ${file}.mp_${timestamp}
    332 
    333                         if {[file exists $file]} {
    334                                 ui_warn "File $file already exists.  Moving to: $bakfile."
    335                                 file rename -force -- $file $bakfile
    336                         }
    337                        
    338                         if { $port != 0 } {
    339                                 set bakport [registry::file_registered $file]
    340                                 registry::unregister_file $file
    341                                 if {[file exists $bakfile]} {
    342                                         registry::register_file $bakfile $bakport
    343                                 }
    344                         }
    345                 }
    346                
    347                 # Split out the filename's subpaths and add them to the imagefile list.
    348                 # We need directories first to make sure they will be there before
    349                 # links. However, because file mkdir creates all parent directories,
    350                 # we don't need to have them sorted from root to subpaths. We do need,
    351                 # nevertheless, all sub paths to make sure we'll set the directory
    352                 # attributes properly for all directories.
    353                 set directory [file dirname $file]
    354                 while { [lsearch -exact $files $directory] == -1 } {
    355                         lappend files $directory
    356                         set directory [file dirname $directory]
    357                 }
    358 
    359                 # Also add the filename to the imagefile list.
    360                 lappend files $file
    361         }
    362         registry::write_file_map
    363 
    364         # Sort the list in forward order, removing duplicates.
    365         # Since the list is sorted in forward order, we're sure that directories
    366         # are before their elements.
    367         # We don't have to do this as mentioned above, but it makes the
    368         # debug output of activate make more sense.
    369         set theList [lsort -increasing -unique $files]
    370 
    371         # Activate it, and catch errors so we can roll-back
    372         if { [catch {set files [_activate_list $theList $imagedir] } result] } {
    373                 ui_debug "Activation failed, rolling back."
    374                 _deactivate_contents $name $imagefiles
    375                 return -code error $result
    376         }
     329        } elseif { [file exists $file] && $force != 1 } {
     330            return -code error "Image error: $file already exists and does not belong to a registered port.  Unable to activate port $name."
     331        } elseif { $force == 1 && [file exists $file] || $port != 0 } {
     332            set bakfile ${file}.mp_${timestamp}
     333
     334            if {[file exists $file]} {
     335                ui_warn "File $file already exists.  Moving to: $bakfile."
     336                file rename -force -- $file $bakfile
     337            }
     338
     339            if { $port != 0 } {
     340                set bakport [registry::file_registered $file]
     341                registry::unregister_file $file
     342                if {[file exists $bakfile]} {
     343                    registry::register_file $bakfile $bakport
     344                }
     345            }
     346        }
     347
     348        # Split out the filename's subpaths and add them to the imagefile list.
     349        # We need directories first to make sure they will be there before
     350        # links. However, because file mkdir creates all parent directories,
     351        # we don't need to have them sorted from root to subpaths. We do need,
     352        # nevertheless, all sub paths to make sure we'll set the directory
     353        # attributes properly for all directories.
     354        set directory [file dirname $file]
     355        while { [lsearch -exact $files $directory] == -1 } {
     356            lappend files $directory
     357            set directory [file dirname $directory]
     358        }
     359
     360        # Also add the filename to the imagefile list.
     361        lappend files $file
     362    }
     363    registry::write_file_map
     364
     365    # Sort the list in forward order, removing duplicates.
     366    # Since the list is sorted in forward order, we're sure that directories
     367    # are before their elements.
     368    # We don't have to do this as mentioned above, but it makes the
     369    # debug output of activate make more sense.
     370    set theList [lsort -increasing -unique $files]
     371
     372    # Activate it, and catch errors so we can roll-back
     373    if { [catch {set files [_activate_list $theList $imagedir] } result] } {
     374        ui_debug "Activation failed, rolling back."
     375        _deactivate_contents $name $imagefiles
     376        return -code error $result
     377    }
    377378}
    378379
    379380proc _deactivate_file {dstfile} {
    380         if { [file type $dstfile] == "link" } {
    381                 ui_debug "deactivating link: $dstfile"
    382                 file delete -- $dstfile
    383         } elseif { [file isdirectory $dstfile] } {
    384                 # 0 item means empty.
    385                 if { [llength [readdir $dstfile]] == 0 } {
    386                         ui_debug "deactivating directory: $dstfile"
    387                         file delete -- $dstfile
    388                 } else {
    389                         ui_debug "$dstfile is not empty"
    390                 }
    391         } else {
    392                 ui_debug "deactivating file: $dstfile"
    393                 file delete -- $dstfile
    394         }
     381    if { [file type $dstfile] == "link" } {
     382        ui_debug "deactivating link: $dstfile"
     383        file delete -- $dstfile
     384    } elseif { [file isdirectory $dstfile] } {
     385        # 0 item means empty.
     386        if { [llength [readdir $dstfile]] == 0 } {
     387            ui_debug "deactivating directory: $dstfile"
     388            file delete -- $dstfile
     389        } else {
     390            ui_debug "$dstfile is not empty"
     391        }
     392    } else {
     393        ui_debug "deactivating file: $dstfile"
     394        file delete -- $dstfile
     395    }
    395396}
    396397
    397398proc _deactivate_list {filelist} {
    398         foreach file $filelist {
    399                 _deactivate_file $file
    400         }
     399    foreach file $filelist {
     400        _deactivate_file $file
     401    }
    401402}
    402403
    403404proc _deactivate_contents {name imagefiles} {
    404         set files [list]
    405        
    406         foreach file $imagefiles {
    407                 if { [file exists $file] || (![catch {file type $file}] && [file type $file] == "link") } {
    408                         # Normalize the file path to avoid removing the intermediate
    409                         # symlinks (remove the empty directories instead)
    410                         # Remark: paths in the registry may be not normalized.
    411                         # This is not really a problem and it is in fact preferable.
    412                         # Indeed, if I change the activate code to include normalized paths
    413                         # instead of the paths we currently have, users' registry won't
    414                         # match and activate will say that some file exists but doesn't
    415                         # belong to any port.
    416                         set theFile [file normalize $file]
    417                         lappend files $theFile
    418                        
    419                         # Split out the filename's subpaths and add them to the image list as
    420                         # well. The realpath call is necessary because file normalize
    421                         # does not resolve symlinks on OS X < 10.6
    422                         set directory [realpath [file dirname $theFile]]
    423                         while { [lsearch -exact $files $directory] == -1 } {
    424                                 lappend files $directory
    425                                 set directory [file dirname $directory]
    426                         }
    427                 } else {
    428                         ui_debug "$file does not exist."
    429                 }
    430         }
    431 
    432         # Sort the list in reverse order, removing duplicates.
    433         # Since the list is sorted in reverse order, we're sure that directories
    434         # are after their elements.
    435         set theList [lsort -decreasing -unique $files]
    436 
    437         # Remove all elements.
    438         if { [catch {_deactivate_list $theList} result] } {
    439                 return -code error $result
    440         }
     405    set files [list]
     406
     407    foreach file $imagefiles {
     408        if { [file exists $file] || (![catch {file type $file}] && [file type $file] == "link") } {
     409            # Normalize the file path to avoid removing the intermediate
     410            # symlinks (remove the empty directories instead)
     411            # Remark: paths in the registry may be not normalized.
     412            # This is not really a problem and it is in fact preferable.
     413            # Indeed, if I change the activate code to include normalized paths
     414            # instead of the paths we currently have, users' registry won't
     415            # match and activate will say that some file exists but doesn't
     416            # belong to any port.
     417            set theFile [file normalize $file]
     418            lappend files $theFile
     419
     420            # Split out the filename's subpaths and add them to the image list as
     421            # well. The realpath call is necessary because file normalize
     422            # does not resolve symlinks on OS X < 10.6
     423            set directory [realpath [file dirname $theFile]]
     424            while { [lsearch -exact $files $directory] == -1 } {
     425                lappend files $directory
     426                set directory [file dirname $directory]
     427            }
     428        } else {
     429            ui_debug "$file does not exist."
     430        }
     431    }
     432
     433    # Sort the list in reverse order, removing duplicates.
     434    # Since the list is sorted in reverse order, we're sure that directories
     435    # are after their elements.
     436    set theList [lsort -decreasing -unique $files]
     437
     438    # Remove all elements.
     439    if { [catch {_deactivate_list $theList} result] } {
     440        return -code error $result
     441    }
    441442}
    442443
  • trunk/base/src/registry1.0/portuninstall.tcl

    r59770 r62701  
    1 # et:ts=4
     1# -*- coding: utf-8; mode: tcl; tab-width: 4; indent-tabs-mode: nil; c-basic-offset: 4 -*- vim:fenc=utf-8:ft=tcl:et:sw=4:ts=4:sts=4
    22# portuninstall.tcl
    33# $Id$
     
    1717#    may be used to endorse or promote products derived from this software
    1818#    without specific prior written permission.
    19 # 
     19#
    2020# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
    2121# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
     
    4040
    4141proc uninstall {portname {v ""} optionslist} {
    42         global uninstall.force uninstall.nochecksum UI_PREFIX
    43         array set options $optionslist
    44 
    45         set ilist [registry::installed $portname $v]
    46         if { [llength $ilist] > 1 } {
    47             set portname [lindex [lindex $ilist 0] 0]
    48                 ui_msg "$UI_PREFIX [msgcat::mc "The following versions of $portname are currently installed:"]"
    49                 foreach i [portlist_sortint $ilist] {
    50                         set iname [lindex $i 0]
    51                         set iversion [lindex $i 1]
    52                         set irevision [lindex $i 2]
    53                         set ivariants [lindex $i 3]
    54                         set iactive [lindex $i 4]
    55                         if { $iactive == 0 } {
    56                                 ui_msg "$UI_PREFIX [format [msgcat::mc "        %s @%s_%s%s"] $iname $iversion $irevision $ivariants]"
    57                         } elseif { $iactive == 1 } {
    58                                 ui_msg "$UI_PREFIX [format [msgcat::mc "        %s @%s_%s%s (active)"] $iname $iversion $irevision $ivariants]"
    59                         }
    60                 }
    61                 return -code error "Registry error: Please specify the full version as recorded in the port registry."
    62         } else {
    63             # set portname again since the one we were passed may not have had the correct case
    64             set portname [lindex [lindex $ilist 0] 0]
    65                 set version [lindex [lindex $ilist 0] 1]
    66                 set revision [lindex [lindex $ilist 0] 2]
    67                 set variants [lindex [lindex $ilist 0] 3]
    68                 set active [lindex [lindex $ilist 0] 4]
    69         }
    70 
    71         # determine if it's the only installed port with that name or not.
    72         if {$v == ""} {
    73                 set nb_versions_installed 1
    74         } else {
    75                 set ilist [registry::installed $portname ""]
    76                 set nb_versions_installed [llength $ilist]
    77         }
    78 
    79         set ref [registry::open_entry $portname $version $revision $variants]
    80 
    81         # If global forcing is on, make it the same as a local force flag.
    82         if {[info exists options(ports_force)] && [string equal -nocase $options(ports_force) "yes"] } {
    83                 set uninstall.force "yes"
    84         }
    85 
    86         # Check and make sure no ports depend on this one
    87         registry::open_dep_map 
    88         set deplist [registry::list_dependents $portname]
    89         if { [llength $deplist] > 0 } {
    90                 set dl [list]
    91                 # Check the deps first
    92                 foreach dep $deplist {
    93                         set depport [lindex $dep 2]
    94                         ui_debug "$depport depends on this port"
    95                         if {[registry::entry_exists_for_name $depport]} {
    96                                 lappend dl $depport
    97                         }
    98                 }
    99                 # Now see if we need to error
    100                 if { [llength $dl] > 0 } {
    101                         if {[info exists options(ports_uninstall_follow-dependents)] && $options(ports_uninstall_follow-dependents) eq "yes"} {
    102                                 foreach depport $dl {
    103                                         # make sure it's still installed, since a previous dep uninstall may have removed it
    104                                         if {[registry::entry_exists_for_name $depport]} {
    105                                                 portuninstall::uninstall $depport "" [array get options]
    106                                         }
    107                                 }
    108                         } else {
     42    global uninstall.force uninstall.nochecksum UI_PREFIX
     43    array set options $optionslist
     44
     45    set ilist [registry::installed $portname $v]
     46    if { [llength $ilist] > 1 } {
     47        set portname [lindex [lindex $ilist 0] 0]
     48        ui_msg "$UI_PREFIX [msgcat::mc "The following versions of $portname are currently installed:"]"
     49        foreach i [portlist_sortint $ilist] {
     50            set iname [lindex $i 0]
     51            set iversion [lindex $i 1]
     52            set irevision [lindex $i 2]
     53            set ivariants [lindex $i 3]
     54            set iactive [lindex $i 4]
     55            if { $iactive == 0 } {
     56                ui_msg "$UI_PREFIX [format [msgcat::mc "    %s @%s_%s%s"] $iname $iversion $irevision $ivariants]"
     57            } elseif { $iactive == 1 } {
     58                ui_msg "$UI_PREFIX [format [msgcat::mc "    %s @%s_%s%s (active)"] $iname $iversion $irevision $ivariants]"
     59            }
     60        }
     61        return -code error "Registry error: Please specify the full version as recorded in the port registry."
     62    } else {
     63        # set portname again since the one we were passed may not have had the correct case
     64        set portname [lindex [lindex $ilist 0] 0]
     65        set version [lindex [lindex $ilist 0] 1]
     66        set revision [lindex [lindex $ilist 0] 2]
     67        set variants [lindex [lindex $ilist 0] 3]
     68        set active [lindex [lindex $ilist 0] 4]
     69    }
     70
     71    # determine if it's the only installed port with that name or not.
     72    if {$v == ""} {
     73        set nb_versions_installed 1
     74    } else {
     75        set ilist [registry::installed $portname ""]
     76        set nb_versions_installed [llength $ilist]
     77    }
     78
     79    set ref [registry::open_entry $portname $version $revision $variants]
     80
     81    # If global forcing is on, make it the same as a local force flag.
     82    if {[info exists options(ports_force)] && [string equal -nocase $options(ports_force) "yes"] } {
     83        set uninstall.force "yes"
     84    }
     85
     86    # Check and make sure no ports depend on this one
     87    registry::open_dep_map 
     88    set deplist [registry::list_dependents $portname]
     89    if { [llength $deplist] > 0 } {
     90        set dl [list]
     91        # Check the deps first
     92        foreach dep $deplist {
     93            set depport [lindex $dep 2]
     94            ui_debug "$depport depends on this port"
     95            if {[registry::entry_exists_for_name $depport]} {
     96                lappend dl $depport
     97            }
     98        }
     99        # Now see if we need to error
     100        if { [llength $dl] > 0 } {
     101            if {[info exists options(ports_uninstall_follow-dependents)] && $options(ports_uninstall_follow-dependents) eq "yes"} {
     102                foreach depport $dl {
     103                    # make sure it's still installed, since a previous dep uninstall may have removed it
     104                    if {[registry::entry_exists_for_name $depport]} {
     105                        portuninstall::uninstall $depport "" [array get options]
     106                    }
     107                }
     108            } else {
    109109                # will need to change this when we get version/variant dependencies
    110110                if {$nb_versions_installed == 1 || $active == 1} {
    111111                    ui_msg "$UI_PREFIX [format [msgcat::mc "Unable to uninstall %s %s_%s%s, the following ports depend on it:"] $portname $version $revision $variants]"
    112112                    foreach depport $dl {
    113                         ui_msg "$UI_PREFIX [format [msgcat::mc "        %s"] $depport]"
     113                        ui_msg "$UI_PREFIX [format [msgcat::mc "    %s"] $depport]"
    114114                    }
    115115                    if { [info exists uninstall.force] && [string equal ${uninstall.force} "yes"] } {
     
    119119                    }
    120120                }
    121                         }
    122                 }
    123         }
    124 
    125         set installtype [registry::property_retrieve $ref installtype]
    126         if { $installtype == "image" && [registry::property_retrieve $ref active] == 1} {
    127                 if {[info exists options(ports_dryrun)] && $options(ports_dryrun) == "yes"} {
    128                         ui_msg "For $portname @${version}_${revision}${variants}: skipping deactivate (dry run)"
    129                 } else {
    130                         portimage::deactivate $portname ${version}_${revision}${variants} $optionslist
    131                 }
    132         }
    133 
    134         if {[info exists options(ports_dryrun)] && $options(ports_dryrun) == "yes"} {
    135                 ui_msg "For $portname @${version}_${revision}${variants}: skipping uninstall (dry run)"
    136                 return 0
    137         }
    138        
    139         ui_msg "$UI_PREFIX [format [msgcat::mc "Uninstalling %s @%s_%s%s"] $portname $version $revision $variants]"
    140 
    141         # Look to see if the port has registered an uninstall procedure
    142         set uninstall [registry::property_retrieve $ref pkg_uninstall]
    143         if { $uninstall != 0 } {
    144                 if {![catch {eval $uninstall} err]} {
    145                         pkg_uninstall $portname ${version}_${revision}${variants}
    146                 } else {
    147                         global errorInfo
    148                         ui_debug "$errorInfo"
    149                         ui_error [format [msgcat::mc "Could not evaluate pkg_uninstall procedure: %s"] $err]
    150                 }
    151         }
    152 
    153         # Remove the port from the deps_map if only one version was installed.
    154         # This is a temporary fix for a deeper problem that is that the dependency
    155         # map doesn't take the port version into account (but should).
    156         # Fixing it means transitionning to a new dependency map format.
    157         if {$nb_versions_installed == 1} {
    158                 registry::unregister_dependencies $portname
    159         }
    160 
    161         # Now look for a contents list
    162         set contents [registry::property_retrieve $ref contents]
    163         if { $contents != "" } {
    164                 set uninst_err 0
    165                 set files [list]
    166                 foreach f $contents {
    167                         set fname [lindex $f 0]
    168                         set md5index [lsearch -regex [lrange $f 1 end] MD5]
    169                         if {$md5index != -1} {
    170                                 set sumx [lindex $f [expr $md5index + 1]]
    171                         } else {
    172                                 # XXX There is no MD5 listed, set sumx to an
    173                                 # empty list, causing the next conditional to
    174                                 # return a checksum error
    175                                 set sumx {}
    176                         }
    177                         set sum1 [lindex $sumx [expr [llength $sumx] - 1]]
    178                         if {![string match $sum1 NONE] && ![info exists uninstall.nochecksum] && ![string equal -nocase $uninstall.nochecksum "yes"] } {
    179                                 if {![catch {set sum2 [md5 $fname]}]} {
    180                                         if {![string match $sum1 $sum2]} {
    181                                                 if {![info exists uninstall.force] && ![string equal -nocase $uninstall.force "yes"] } {
    182                                                         ui_info "$UI_PREFIX  [format [msgcat::mc "Original checksum does not match for %s, not removing"] $fname]"
    183                                                         set uninst_err 1
    184                                                         continue
    185                                                 } else {
    186                                                         ui_info "$UI_PREFIX  [format [msgcat::mc "Original checksum does not match for %s, removing anyway [force in effect]"] $fname]"
    187                                                 }
    188                                         }
    189                                 }
    190                         }
    191                        
    192                         set theFile [file normalize $fname]
    193                         if { [file exists $theFile] || (![catch {file type $theFile}] && [file type $theFile] == "link") } {
    194                             # Normalize the file path to avoid removing the intermediate
    195                             # symlinks (remove the empty directories instead)
    196                             lappend files $theFile
    197 
    198                             # Split out the filename's subpaths and add them to the
    199                             # list as well. The realpath call is necessary because file normalize
    200                             # does not resolve symlinks on OS X < 10.6
    201                             set directory [realpath [file dirname $theFile]]
    202                             while { [lsearch -exact $files $directory] == -1 } {
    203                                     lappend files $directory
    204                                     set directory [file dirname $directory]
    205                             }
    206                         }
    207                 }
    208 
    209                 # Sort the list in reverse order, removing duplicates.
    210                 # Since the list is sorted in reverse order, we're sure that directories
    211                 # are after their elements.
    212                 set theList [lsort -decreasing -unique $files]
    213 
    214                 # Remove all elements.
    215                 if { [catch {_uninstall_list $theList} result] } {
    216                         return -code error $result
    217                 }
    218 
    219                 if {!$uninst_err || [info exists uninstall.force] && [string equal -nocase $uninstall.force "yes"] } {
    220                         ui_info "$UI_PREFIX [format [msgcat::mc "Uninstall is removing %s from the port registry."] $portname]"
    221                         registry::delete_entry $ref
    222                         return 0
    223                 }
    224        
    225         } else {
    226                 return -code error [msgcat::mc "Uninstall failed: Port has no contents entry"]
    227         }
     121            }
     122        }
     123    }
     124
     125    set installtype [registry::property_retrieve $ref installtype]
     126    if { $installtype == "image" && [registry::property_retrieve $ref active] == 1} {
     127        if {[info exists options(ports_dryrun)] && $options(ports_dryrun) == "yes"} {
     128            ui_msg "For $portname @${version}_${revision}${variants}: skipping deactivate (dry run)"
     129        } else {
     130            portimage::deactivate $portname ${version}_${revision}${variants} $optionslist
     131        }
     132    }
     133
     134    if {[info exists options(ports_dryrun)] && $options(ports_dryrun) == "yes"} {
     135        ui_msg "For $portname @${version}_${revision}${variants}: skipping uninstall (dry run)"
     136        return 0
     137    }
     138   
     139    ui_msg "$UI_PREFIX [format [msgcat::mc "Uninstalling %s @%s_%s%s"] $portname $version $revision $variants]"
     140
     141    # Look to see if the port has registered an uninstall procedure
     142    set uninstall [registry::property_retrieve $ref pkg_uninstall]
     143    if { $uninstall != 0 } {
     144        if {![catch {eval $uninstall} err]} {
     145            pkg_uninstall $portname ${version}_${revision}${variants}
     146        } else {
     147            global errorInfo
     148            ui_debug "$errorInfo"
     149            ui_error [format [msgcat::mc "Could not evaluate pkg_uninstall procedure: %s"] $err]
     150        }
     151    }
     152
     153    # Remove the port from the deps_map if only one version was installed.
     154    # This is a temporary fix for a deeper problem that is that the dependency
     155    # map doesn't take the port version into account (but should).
     156    # Fixing it means transitionning to a new dependency map format.
     157    if {$nb_versions_installed == 1} {
     158        registry::unregister_dependencies $portname
     159    }
     160
     161    # Now look for a contents list
     162    set contents [registry::property_retrieve $ref contents]
     163    if { $contents != "" } {
     164        set uninst_err 0
     165        set files [list]
     166        foreach f $contents {
     167            set fname [lindex $f 0]
     168            set md5index [lsearch -regex [lrange $f 1 end] MD5]
     169            if {$md5index != -1} {
     170                set sumx [lindex $f [expr $md5index + 1]]
     171            } else {
     172                # XXX There is no MD5 listed, set sumx to an
     173                # empty list, causing the next conditional to
     174                # return a checksum error
     175                set sumx {}
     176            }
     177            set sum1 [lindex $sumx [expr [llength $sumx] - 1]]
     178            if {![string match $sum1 NONE] && ![info exists uninstall.nochecksum] && ![string equal -nocase $uninstall.nochecksum "yes"] } {
     179                if {![catch {set sum2 [md5 $fname]}]} {
     180                    if {![string match $sum1 $sum2]} {
     181                        if {![info exists uninstall.force] && ![string equal -nocase $uninstall.force "yes"] } {
     182                            ui_info "$UI_PREFIX  [format [msgcat::mc "Original checksum does not match for %s, not removing"] $fname]"
     183                            set uninst_err 1
     184                            continue
     185                        } else {
     186                            ui_info "$UI_PREFIX  [format [msgcat::mc "Original checksum does not match for %s, removing anyway [force in effect]"] $fname]"
     187                        }
     188                    }
     189                }
     190            }
     191           
     192            set theFile [file normalize $fname]
     193            if { [file exists $theFile] || (![catch {file type $theFile}] && [file type $theFile] == "link") } {
     194                # Normalize the file path to avoid removing the intermediate
     195                # symlinks (remove the empty directories instead)
     196                lappend files $theFile
     197
     198                # Split out the filename's subpaths and add them to the
     199                # list as well. The realpath call is necessary because file normalize
     200                # does not resolve symlinks on OS X < 10.6
     201                set directory [realpath [file dirname $theFile]]
     202                while { [lsearch -exact $files $directory] == -1 } {
     203                    lappend files $directory
     204                    set directory [file dirname $directory]
     205                }
     206            }
     207        }
     208
     209        # Sort the list in reverse order, removing duplicates.
     210        # Since the list is sorted in reverse order, we're sure that directories
     211        # are after their elements.
     212        set theList [lsort -decreasing -unique $files]
     213
     214        # Remove all elements.
     215        if { [catch {_uninstall_list $theList} result] } {
     216            return -code error $result
     217        }
     218
     219        if {!$uninst_err || [info exists uninstall.force] && [string equal -nocase $uninstall.force "yes"] } {
     220            ui_info "$UI_PREFIX [format [msgcat::mc "Uninstall is removing %s from the port registry."] $portname]"
     221            registry::delete_entry $ref
     222            return 0
     223        }
     224   
     225    } else {
     226        return -code error [msgcat::mc "Uninstall failed: Port has no contents entry"]
     227    }
    228228}
    229229
    230230proc _uninstall_file {dstfile} {
    231         if { ![catch {set type [file type $dstfile]}] } {
    232                 if { $type == "link" } {
    233                         ui_debug "uninstalling link: $dstfile"
    234                         file delete -- $dstfile
    235                 } elseif { [file isdirectory $dstfile] } {
    236                         # 0 item means empty.
    237                         if { [llength [readdir $dstfile]] == 0 } {
    238                                 ui_debug "uninstalling directory: $dstfile"
    239                                 file delete -- $dstfile
    240                         } else {
    241                                 ui_debug "$dstfile is not empty"
    242                         }
    243                 } else {
    244                         ui_debug "uninstalling file: $dstfile"
    245                         file delete -- $dstfile
    246                 }
    247         } else {
    248                 ui_debug "skip missing file: $dstfile"
    249         }
     231    if { ![catch {set type [file type $dstfile]}] } {
     232        if { $type == "link" } {
     233            ui_debug "uninstalling link: $dstfile"
     234            file delete -- $dstfile
     235        } elseif { [file isdirectory $dstfile] } {
     236            # 0 item means empty.
     237            if { [llength [readdir $dstfile]] == 0 } {
     238                ui_debug "uninstalling directory: $dstfile"
     239                file delete -- $dstfile
     240            } else {
     241                ui_debug "$dstfile is not empty"
     242            }
     243        } else {
     244            ui_debug "uninstalling file: $dstfile"
     245            file delete -- $dstfile
     246        }
     247    } else {
     248        ui_debug "skip missing file: $dstfile"
     249    }
    250250}
    251251
    252252proc _uninstall_list {filelist} {
    253         foreach file $filelist {
    254                 _uninstall_file $file
    255         }
     253    foreach file $filelist {
     254        _uninstall_file $file
     255    }
    256256}
    257257
Note: See TracChangeset for help on using the changeset viewer.