#!/bin/sh
# -*- 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
# \
if test -x @prefix@/bin/port-tclsh; then exec @prefix@/bin/port-tclsh "$0" "$@"; else exec /usr/bin/tclsh "$0" "$@"; fi
# $Id$

set VERSION 0.1.4
set prefix "@prefix@"

# - Procedures ---------------------------------------------------------------

proc composite_version {port} {
    return [version $port]_[revision $port][variants $port]
}

proc cut_leaves {{processed_leaves {}}} {
    global exit_status option

    if {[catch {set leaves [leaves]} result]} {
        puts stderr "Error: $result"
        return 1
    }

    set to_process {}
    foreach leaf $leaves {
        set full_name [full_name $leaf]
        if {[lsearch -exact $processed_leaves $full_name] != -1} {
            continue
        }
        lappend processed_leaves    $full_name
        lappend to_process          $leaf
    }

    set total_leaves [llength $to_process]
    if {$total_leaves < 1} {
        puts "There are no new leaves to process."
        return $exit_status
    }

    set current_leaf    1
    set flush_now       0
    set to_uninstall    {}

    foreach leaf $to_process {
        set composite_version   [composite_version $leaf]
        set full_name           [full_name $leaf]
        set name                [name $leaf]

        set status active
        if {![is_active $leaf]} {
            set status inactive
        }

        while {1} {
            puts "\[Leaf $current_leaf of $total_leaves] $full_name ($status):"
            puts -nonewline "  \[keep] / (u)ninstall / (f)lush / (a)bort: "
            flush stdout

            gets stdin action
            switch -glob $action {
                a* {
                    puts "\nAborting port_cutleaves..."
                    return $exit_status
                }
                f* {
                    puts "\nFlushing any uninstallation operations...\n"
                    set flush_now 1
                }
                u* {
                    puts "** $full_name will be uninstalled.\n"
                    lappend to_uninstall $leaf
                }
                k* -
                ""
                {
                    puts "** $full_name will be kept.\n"
                }
                default {
                    puts "** '$action' is an invalid action.\n"
                    continue
                }
            }

            break
        }

        if {$flush_now == 1} {
            break
        }

        incr current_leaf
    }

    if {[llength $to_uninstall] < 1} {
        puts "No leaves were marked for uninstallation."
        return $exit_status
    }

    set uninstalled [uninstall $to_uninstall]
    if {[llength $uninstalled] < 1} {
        puts "\nNo leaves were uninstalled."
        return 1
    }

    puts "\nThe following ports were uninstalled:"
    foreach port $uninstalled {
        puts "  $port"
    }

    puts "\nSearch for new leaves?"
    puts -nonewline "  \[no] / (y)es: "
    flush stdout

    gets stdin choice
    if {[regexp {^y} $choice]} {
        puts {}
        return [cut_leaves $processed_leaves]
    }

    return $exit_status
}

proc exclusions {file} {
    global cached_exclusions

    if {![info exists cached_exclusions]} {
        if {![file exists $file]} {
            return -code error "'$file' does not exist."
        } elseif {[catch {set exclusions_file [open $file]} result]} {
            return -code error $result
        }

        set cached_exclusions {}
        foreach line [split [read -nonewline $exclusions_file] \n] {
            switch -regexp $line {
                {^\s*#} -
                {^$}    {}
                default { lappend cached_exclusions $line }
            }
        }
        close $exclusions_file
    }

    return $cached_exclusions
}

proc full_name {port} {
    return "[name $port] @[composite_version $port]"
}

proc is_active {port} {
    return [lindex $port 4]
}

proc collect_build_deps {installedvar} {
    upvar $installedvar installed
    global build_deps
    array unset build_deps
    foreach i $installed {
        set iname [name $i]
        if {[catch {set res [mportlookup $iname]} result]} {
            puts stderr "lookup of portname $iname failed: $result"
            exit 1
        }
        if {[llength $res] < 2} {
            continue
        } else {
            array unset portinfo
            array set portinfo [lindex $res 1]
        }
        foreach type {depends_fetch depends_extract depends_build} {
            if {[info exists portinfo($type)]} {
                foreach d $portinfo($type) {
                    set build_deps([lindex [split $d :] end]) 1
                }
            }
        }
    }
}

proc leaves {} {
    global option build_deps
    registry::open_dep_map

    if {[catch {set installed [registry::installed]} result]} {
        return -code error $result
    } elseif {[catch {set exclusions [exclusions $option(F)]} result]} {
        if {![regexp {does not exist} $result]} {
            return -code error $result
        }
        set exclusions {}
    }
    if {$option(b)} {
        collect_build_deps installed
    }

    set leaves {}
    foreach port $installed {
        if {${macports::registry.format} eq "receipt_sqlite"} {
            set regref [registry::open_entry [name $port] [version $port] [revision $port] [variants $port] [epoch $port]]
        } else {
            set regref [registry::open_entry [name $port] [version $port] [revision $port] [variants $port]]
        }
        if {![registry::property_retrieve $regref requested]
            && [registry::list_dependents [name $port]] eq ""
            && ![should_be_excluded $port $exclusions]
            && (!$option(b) || ![info exists build_deps([name $port])])} {
            lappend leaves $port
        }
    }
    return $leaves
}

proc list_leaves {} {
    if {[catch {set leaves [leaves]} result]} {
        puts stderr "Error: $result"
        return 1
    }

    foreach leaf $leaves {
        puts [full_name $leaf]
    }
    return 0
}

proc epoch {port} {
    return [lindex $port 5]
}

proc name {port} {
    return [lindex $port 0]
}

proc revision {port} {
    return [lindex $port 2]
}

proc should_be_excluded {port exclusions} {
    foreach exclusion $exclusions {
        set full_name [full_name $port]
        if {[string equal -nocase $exclusion $full_name] || [regexp -nocase $exclusion $full_name]} {
            return 1
        }
    }
    return 0
}

proc uninstall {ports} {
    global exit_status

    set uninstalled {}
    foreach port $ports {
        if {${macports::registry.format} eq "receipt_sqlite"} {
            set regref [registry::open_entry [name $port] [version $port] [revision $port] [variants $port] [epoch $port]]
            if {[registry::run_target $regref uninstall {}]} {
                lappend uninstalled [full_name $port]
                continue
            }
        }
        if {[llength [info commands "registry_uninstall::uninstall"]] == 1} {
            if {[llength [info commands "registry_uninstall::uninstall_composite"]] == 1} {
                if {[catch {registry_uninstall::uninstall [name $port] [version $port] [revision $port] [variants $port] {}} \
                            result]} {
                    set exit_status 1
                    puts stderr "Error: $result"
                    continue
                }
            } else {
                if {[catch {registry_uninstall::uninstall [name $port] [composite_version $port] {}} \
                            result]} {
                    set exit_status 1
                    puts stderr "Error: $result"
                    continue
                }
            }
        } elseif {[catch {portuninstall::uninstall [name $port] [composite_version $port] {}} \
                         result]} {
                set exit_status 1
                puts stderr "Error: $result"
                continue
        }
        lappend uninstalled [full_name $port]
    }
    return $uninstalled
}

proc variants {port} {
    return [lindex $port 3]
}

proc version {port} {
    return [lindex $port 1]
}

# - Main ---------------------------------------------------------------------

package require cmdline
set options {
    { b     "Don't count ports as leaves when they are only needed at build time" }
    { F.arg ~/.port_leaves.exclude \
            "Specify a different file to read exclusions from" }
    { l     "List leaves and exit"}
    { V     "Display version information and exit" }
}
set usage "\[-b] \[-F value] \[-l] \[-t value] \[-V] \[-help] \[-?]\n\nOptions:"
if {[catch {array set option [::cmdline::getoptions argv $options]}]} {
    puts [::cmdline::usage $options $usage]
    exit 1
}

if {![file exists ${prefix}/bin/port-tclsh]} {
    if {[catch {source ${prefix}/share/macports/Tcl/macports1.0/macports_fastload.tcl} result]} {
        puts stderr "Error: $result"
        exit 1
    }
}

package require macports
if {[catch {mportinit} result]} {
    puts stderr "Error: $result"
    exit 1
}

set exit_status 0

if {$option(V)} {
    exit [puts port_cutleaves-$VERSION]
} elseif {$option(l)} {
    exit [list_leaves]
} else {
    exit [cut_leaves]
}