# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt
#
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem.
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository.
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# (C) 2023
#
# @@ Meta Begin
# Application punk::winpath 999999.0a1.0
# Meta platform     tcl
# Meta license      BSD 
# @@ Meta End



# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
##  Requirements
##e.g package require frobz




# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval punk::winpath {
    namespace export winpath windir cdwin cdwindir illegalname_fix illegalname_test




    #\\servername\share etc  or \\?\UNC\servername\share  etc.
    proc is_unc_path {path} {
        set strcopy_path [punk::winpath::system::objclone $path]
        set strcopy_path [string map {\\ /} $strcopy_path] ;#normalize to forward slashes for testing purposes (and forward slashes seem to be auto-translated by windows anyway)
        if {[string first "//" $strcopy_path] == 0} {
            #check for "Dos device path" syntax
            if {[string range $strcopy_path 0 3] in {//?/ //./}} {
                #Note that //./ doesn't appear to be supported in Tcl as at 2023-08 - but //?/ works  (except for //?/UNC/Server/share)
                if {[string range $strcopy_path 4 6] eq "UNC"} {
                    return 1
                } else {
                    #some other Dos device path. Could be a drive which is mapped to a UNC path - but the path itself isn't a unc path
                    return 0
                }
            } else {
                #leading double slash and not dos device path syntax
                return 1
            }
        }
        return 0
    }

    #ordinary \\Servername   or \\servername\share or \\servername\share\path  (or forward-slash equivalent) with no dos device syntax //?/ //./ etc.
    proc is_unc_path_plain {path} {
        if {[is_unc_path $path]} {
            if {![is_dos_device_path $path]} {
                return 1
            } else {
                return 0
            }
        } else {
            return 0
        }
    }

    #int-rep path preserved - but 'file attributes', and therefor this operation, is expensive (on windows at least)
    proc pwdshortname {{path {}}} {
        if {$path eq ""} {
           set path [pwd]
        } else {
            if {[file pathtype $path] eq "relative"} {
                set path [file normalize $path]
            }
        }
        return [dict get [file attributes $path] -shortname]
    }
    #dos device path syntax allows windows api to acces extended-length paths and filenames with illegal path characters such as trailing dots or whitespace
    #(can exist on server shares and on NTFS - but standard apps can't access without dos device syntax)
    proc is_dos_device_path {path} {
        set strcopy_path [punk::winpath::system::objclone $path]
        set strcopy_path [string map {\\ /} $strcopy_path] ;#normalize to forward slashes for testing purposes (and forward slashes seem to be auto-translated by windows anyway)
        if {[string range $strcopy_path 0 3] in {//?/ //./}} {
            return 1
        } else {
            return 0
        }
    }
    proc strip_dos_device_prefix {path} {
        #it's unlikely to be valid to strip only //?/ from a //?/UNC  path so check for it here and diver to strip that.
        #(review.. or raise error because a //?/UNC path isn't an ordinary dos device path? )
        if {[is_unc_path $path]} {
            return [strip_unc_path_prefix $path]
        }
        if {[is_dos_device_path $path]} {
            return [string range $path 4 end]
        } else {
            return $path
        }
    }
    proc strip_unc_path_prefix {path} {
        if {[is_unc_path_plain $path]} {
            #plain unc //server
            set strcopy_path [punk::winpath::system::objclone $path]
            set trimmedpath [string range $strcopy_path 2 end]
            file pathtype $trimmedpath
            return $trimmedpath
        } elseif {is_unc_path $path} {
            #//?/UNC/server/subpath  or  //./UNC/server/subpath
            set strcopy_path [punk::winpath::system::objclone $path]
            set trimmedpath [string range $strcopy_path 7 end]
            file pathtype $trimmedpath ;#shimmer it to path rep
            return $trimmedpath
        } else {
            return $path
        }
    }
    #we don't validate that path is actually illegal because we don't know the full range of such names.
    #The caller can apply this to any path.
    #don't test for platform here - needs to be callable from any platform for potential passing to windows (what usecase? 8.3 name is not always calculable independently)
    #The utility of this is questionable. prepending a dos-device path won't make a filename with illegal characters readable by windows.
    #It will need the 'shortname' at least for the illegal segment - if not the whole path
    #Whilst the 8.3 name algorithm - including undocumented hash function has been reverse engineered 
    #- it depends on the content of the directory - as collisions cause a different name (e.g incremented number) 
    #- it also depends on the history of the folder
    #- you can't take the current dir contents and a particular *existing* longname and determine the shortname algorithmically...
    #- the shortname may have been generated during a different directory state.
    #- It is then stored on disk (where?) - so access to reading the existing shortname is required.
    #- An implementation of the 8.3 algorithm would only be potentially useful in determining the name that will result from adding a new file 
    #  and would be subject to potential collisions if there are race-conditions in file creation
    #- Using an 8.3 algorithm externally would be dangerous in that it could appear to work a lot of the time - but return a different file entirely sometimes.
    #- Conclusion is that the 8.3 name must be retrieved rathern than calclated
    proc illegalname_fix {path} {
        #don't add extra dos device path syntax protection-prefix if already done
        if {[is_unc_path $path]} {
            error "illegalname_fix called on UNC path $path - unable to process"
        }
        if {[is_dos_device_path $path]} {
            #we may have appended 
            return $path
        }



        #\\servername\share theoretically maps to: \\?\UNC\servername\share  in protected form. https://learn.microsoft.com/en-us/dotnet/standard/io/file-path-formats
        #NOTE: 2023-08 on windows 10 at least  \\?\UNC\Server\share  doesn't work - ie we can't use illegalname_fix on UNC paths such as \\Server\share 
        #(but mapped drive to same path will work)
        #Note that test-path cmdlet in powershell is also flaky with regards to \\?\UNC\Server paths.
        #It seems prudent for now to disallow \\?\ protection for UNC paths such as \\server\etc
        if {[is_unc_path $path]} {
            set err ""
            append err      "illegalname_fix doesn't currently support UNC paths (non dos device leading double slash or //?/UNC/...)"
            append err \n   " - because //?/UNC/Servername/share is not supported in Tcl (and only minimally even in powershell) as at 2023. (on windows use mapped drive instead)"
            error $err
        }

        set strcopy_path [punk::winpath::system::objclone $path]


        #Note: path could still have leading double slash if it is a Dos device path: e.g. //?/c:/etc
        if {[file pathtype $path] eq "absolute"} {
            if {$path eq "~"} {
                # non-normalized ~ is classified as absolute
                # tilde special meaning is a bit of a nuisance..  but as it's the entire path in this case.. presumably it should be kept that way
                # leave for caller to interpret it - but it's not an illegal name whether it's interpreted with special meaning or not
                # unlikely this fix will be called on a plain tilde anyway
                return $path
            } else {
                set fullpath $path
            }
        } else {
            #set fullpath [file normalize $path] ;#very slow on windows
            #set fullpath [pwd]/$path ;#will keep ./ in middle of path - not valid for dos-device paths
            if {[string range $strcopy_path 0 1] eq "./"} {
                set strcopy_path [string range $strcopy_path 2 end]
            }
            set fullpath [file join [pwd] $strcopy_path]
        }
        #For file I/O, the "\\?\" prefix to a path string tells the Windows APIs to disable all string parsing
        # and to send the string that follows it straight to the file system.
        set protect "\\\\?\\"  ;# value is: \\?\ prefix   
        set protect2 "//?/" ;#file normalize may do this - it still works 
        #don't use "//./" - not currently supported in Tcl - seems to work in powershell though.


        #choose //?/  as normalized version - since likely 'file normalize' will do it anyway, and experimentall, the windows API accepts both  REVIEW
        set result ${protect2}$fullpath
        file pathtype $result ;#make it return a path rep
        return $result
    }

    #don't test for platform here - needs to be callable from any platform for potential passing to windows
    #we can create files with windows illegal names by using //?/ dos device path syntax - but we need to detect when that is required.
    #
    # path int-rep preserving
    proc illegalname_test {path} {
        #https://learn.microsoft.com/en-us/windows/win32/fileio/naming-a-file
        #according to the above: Use any character in the current code page for a name, including Unicode characters and characters in the extended character set (128–255), except for the following:
        set reserved [list  < > : \" / \\ | ? *]


        #we need to exclude things like path/..   path/.
        foreach seg [file split $path] {
            if {$seg in [list . ..]} {
                #review - what if there is a folder or file that actually has a name such as . or .. ? 
                #unlikely in normal use - but could done deliberately for bad reasons?
                #We are unable to check for it here anyway - as this command is intended for checking the path string - not the actual path on a filesystem.
                #
                #/./  /../  segments don't require protection - keep checking.
                continue
            }

            #only check for actual space as other whitespace seems to work without being stripped
            #trailing tab and trailing \n or \r seem to be creatable in windows with Tcl - map to some glyph
            if {[string index $seg end] in [list " " "."]} {
                #windows API doesn't handle trailing dots or spaces (silently strips) - even though such files can be created on NTFS systems (or seen via samba etc)
                return 1
            }
        }
        #glob chars '* ?' are probably illegal.. but although x*y.txt and x?y.txt don't display properly (* ? replaced with some other glyph)
        #- they seem to be readable from cmd and tclsh as is.
        # pipe symbol also has glyph substitution and behaves the same  e.g a|b.txt
        #(at least with encoding system utf-8)

        #todo - determine what else constitutes an illegal name according to windows APIs and requires protection with dos device syntax
        return 0
    }

    proc shortname {path} {
        set shortname "NA"
        if {[catch {
            set shortname [dict get [file attributes $path] -shortname]
        } errM]} {
            puts stderr "Failed to get shortname for '$path'"
        }
        return $shortname
    }
    proc test_ntfs_tunneling {prefix args} {
        puts stderr "We are looking for whether any of the final $prefix files or dirs took over the ctime attribute of the original $prefix files or dirs"
        puts stderr "We expect the ino values to get potentially reassigned depending on order of deletion/creation so matches are coincidental and not material"
        puts stderr "The shortnames are similarly allocated as they come - so presumably match by coincidence"
        puts stderr "However - if we record a file's shortname, then delete it. Recreating it by shortname within the tunneling timeframe will magically reassociate the longname"
        puts stderr "use test_ntfs_tunneling2 to test shortname tunneling"
        file mkdir $prefix-dir-rename
        file mkdir $prefix-dir-recreate
        set fd [open $prefix-file-recreate.txt w]
        puts $fd "original for recreate"
        close $fd
        set fd [open $prefix-file-rename.txt w]
        puts $fd "original for rename"
        close $fd
        puts stdout "ORIGINAL files/dirs"
        puts stdout "$prefix-dir-rename           [file stat $prefix-dir-rename] "
        puts stdout "$prefix-dir-recreate         [file stat $prefix-dir-recreate]"
        puts stdout "$prefix-file-recreate.txt    [file stat $prefix-file-recreate.txt] short:[shortname $prefix-file-recreate.txt]"
        puts stdout "$prefix-file-rename.txt      [file stat $prefix-file-rename.txt] short:[shortname $prefix-file-rename.txt]"
        puts stderr  "waiting 10secs (to have discernable ctime differences)"
        after 5000 
        puts -nonewline stderr .
        after 5000 
        puts -nonewline stderr .
        after 500 

        #--
        #seems to make no diff whether created or copied - no tunneling seen with dirs
        #file mkdir $prefix-dir-rename-temp
        file copy $prefix-dir-rename $prefix-dir-rename-temp
        #-- 
        puts stderr \n
        puts stdout "$prefix-dir-rename-temp       [file stat $prefix-dir-rename-temp] (temp to rename into place)"
        puts stderr "deleting $prefix-dir-rename"
        file delete $prefix-dir-rename
        puts stdout "renaming $prefix-dir-rename-temp to $prefix-dir-rename"
        file rename $prefix-dir-rename-temp $prefix-dir-rename

        puts stderr "deleting $prefix-dir-recreate"
        file delete $prefix-dir-recreate
        puts stdout "re-creating $prefix-dir-recreate"
        file mkdir $prefix-dir-recreate

        puts stderr "deleting $prefix-file-recreate.txt"
        file delete $prefix-file-recreate.txt
        puts stderr "Recreating $prefix-file-recreate.txt"
        set fd [open $prefix-file-recreate.txt w]
        puts $fd "replacement"
        close $fd
        
        puts stderr "copying $prefix-file-rename.txt to $prefix-file-rename-temp.txt"
        file copy $prefix-file-rename.txt $prefix-file-rename-temp.txt
        puts stdout "$prefix-file-rename-temp.txt [file stat $prefix-file-rename-temp.txt] short:[shortname $prefix-file-rename-temp.txt] (status of initial temp copy)"
        puts stderr "modifying temp copy before deletion of original.. (append)"
        set fd [open $prefix-file-rename-temp.txt a] 
        puts $fd "added to file"
        close $fd
        puts stdout "$prefix-file-rename-temp.txt [file stat $prefix-file-rename-temp.txt] short:[shortname $prefix-file-rename-temp.txt] (status of appended temp copy)"
        puts stderr "deleting $prefix-file-rename.txt"
        file delete  $prefix-file-rename.txt
        puts stderr "renaming temp file $prefix-file-rename-temp.txt to original $prefix-file-rename.txt"
        file rename $prefix-file-rename-temp.txt $prefix-file-rename.txt

        puts stdout "Final files/dirs"
        puts stdout "$prefix-dir-rename           [file stat $prefix-dir-rename]"
        puts stdout "$prefix-dir-recreate         [file stat $prefix-dir-recreate]"
        puts stdout "$prefix-file-recreate.txt    [file stat $prefix-file-recreate.txt] short:[shortname $prefix-file-recreate.txt]"
        puts stdout "$prefix-file-rename.txt      [file stat $prefix-file-rename.txt] short:[shortname $prefix-file-rename.txt]"
    }
    proc test_ntfs_tunneling2 {prefix {waitms 15000}} {
        #shortname -> longname tunneling
        puts stderr "Tunneling only happens if we delete via shortname? review"
        set f1 $prefix-longname-file1.txt
        set f2 $prefix-longname-file2.txt

        set fd [open $f1 w];close $fd
        set shortname1 [shortname $f1] 
        puts stderr "longname:$f1 has shortname:$shortname1"
        set fd [open $f2 w];close $fd
        set shortname2 [shortname $f2] 
        puts stderr "longname:$f2 has shortname:$shortname2"

        puts stderr "deleting $f1 via name $shortname1"
        file delete $shortname1
        puts stdout "immediately recreating $shortname1 - should retain longname $f1 via tunneling"
        set fd [open $shortname1 w];close $fd
        set f1_exists [file exists $f1]
        puts stdout "file exists $f1 = $f1_exists"

        puts stderr "deleting $f2 via name $shortname2"
        file delete $shortname2
        puts stderr "Waiting [expr {$waitms / 1000}] seconds.. (standard tunneling timeframe is 15 seconds if registry hasn't been tweaked)"
        after $waitms
        puts stdout "recreating $shortname2 after wait of $waitms ms - longname lost?" 
        set fd [open $shortname2 w];close $fd
        set f2_exists [file exists $f2]
        puts stdout "file exists $f2 = $f2_exists"

        puts stdout -done-
    }
}


namespace eval punk::winpath::system {
    #get a copy of the item without affecting internal rep
    proc objclone {obj} {
        append obj2 $obj {}
    }
}











# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
##  Ready   
package provide punk::winpath [namespace eval punk::winpath {
    variable version
    set version 999999.0a1.0 
}]
return