#!/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 /opt/local/bin/port-tclsh; then exec /opt/local/bin/port-tclsh "$0" "$@"; else exec /usr/bin/tclsh "$0" "$@"; fi

set VERSION 0.1.5
set prefix "/opt/local"

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

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

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 {[dict exists $processed_leaves $full_name]} {
            continue
        }
        dict set processed_leaves $full_name 1
        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 full_name           [full_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 "[$port name] @[composite_version $port]"
}

proc is_active {port} {
    return [expr {[$port state] eq "installed"}]
}

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

proc leaves {} {
    global option build_deps

    if {[catch {set installed [registry::entry imaged]} 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 {![$port requested]
            && [$port dependents] eq {}
            && ![should_be_excluded $port $exclusions]
            && (!$option(b) || ![dict exists $build_deps [$port name]])} {
            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 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 {
        set fullname [full_name $port]
        if {[registry::run_target $port uninstall {}]} {
            lappend uninstalled $fullname
            continue
        }
        if {[catch {registry_uninstall::uninstall [$port name] [$port version] [$port revision] [$port variants] {}} \
                    result]} {
            set exit_status 1
            puts stderr "Error: $result"
            continue
        }
        lappend uninstalled $fullname
    }
    return $uninstalled
}

# - 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
}

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]
}
