path.jam

boost库提供标准的C++ API 配合dev c++使用,功能更加强大

#  Copyright (C) Vladimir Prus 2002. Permission to copy, use, modify, sell and
#  distribute this software is granted provided this copyright notice appears in
#  all copies. This software is provided "as is" without express or implied
#  warranty, and with no claim as to its suitability for any purpose.

#  Performs various path manipulations. Path are always in a 'normilized' 
#  representation. In it, a path may be either:
#
#     - '.', or
#
#     - ['/'] [ ( '..' '/' )*  (token '/')* token ]
# 
#   In plain english, path can be rooted, '..' elements are allowed only
#   at the beginning, and it never ends in slash, except for path consisting
#   of slash only.

import modules ;
import sequence ;
import regex ;
import errors : error ;


os = [ modules.peek : OS ] ;
if [ modules.peek : UNIX ] 
{    
    local uname = [ modules.peek : JAMUNAME ] ;
    switch $(uname)
    {
        case CYGWIN* :
          os = CYGWIN ;
        
        case * :
          os = UNIX ;
    }        
}

#
#    Converts the native path into normalized form.
#
rule make ( native )
{
    return [ make-$(os) $(native) ] ;
}

#
#    Builds native representation of the path.
#
rule native ( path )
{
    return [ native-$(os) $(path) ] ;
}

#
#    Tests if a path is rooted.
#
rule is-rooted ( path )
{
    return [ MATCH "^(/)" : $(path) ] ;
}

#
#    Tests if a path has a parent.
#
rule has-parent ( path )
{
    if $(path) != / {
        return 1 ;
    } else {
        return ;
    }
}

#
#    Returns the path without any directory components.
#
rule basename ( path )
{
    return [ MATCH "([^/]+)$" : $(path) ] ;
}

#
#    Returns parent directory of the path. If no parent exists, error is issued.
#
rule parent ( path )
{
    if [ has-parent $(path) ] {

        if $(path) = . {
            return .. ;
        } else {

            # Strip everything at the end of path up to and including
            # the last slash
            local result = [ regex.match "((.*)/)?([^/]+)" : $(path) : 2 3 ] ;

            # Did we strip what we shouldn't?
            if $(result[2]) = ".." {
                return $(path)/.. ;
            } else {
                if ! $(result[1]) {
                    if [ is-rooted $(path) ] {
                        result = / ;
                    } else {
                        result = . ;
                    }
                }
                return $(result[1]) ;
            }
        }
    } else {
        error "Path '$(path)' has no parent" ;
    }
}

#
#    Returns path2 such that "[ join path path2 ] = .".
#    The path may not contain ".." element or be rooted.
#
rule reverse ( path )
{
    if $(path) = .
    {
        return $(path) ;
    }
    else
    {
        local tokens = [ regex.split $(path) "/" ] ;
        local tokens2 ;
        for local i in $(tokens) {
            tokens2 += .. ;
        }
        return [ sequence.join $(tokens2) : "/" ] ;
    }
}

#
# Auxillary rule: does all the semantic of 'join', except for error cheching.
# The error checking is separated because this rule is recursive, and I don't
# like the idea of checking the same input over and over.
#
local rule join-imp ( elements + )
{
    return [ NORMALIZE_PATH $(elements:J="/") ] ;
}

#
#    Contanenates the passed path elements. Generates an error if
#    any element other than the first one is rooted.
#
rule join ( elements + )
{
    if ! $(elements[2]) 
    {
        return $(elements[1]) ;
    }
    else
    {        
        for local e in $(elements[2-])
        {
            if [ is-rooted $(e) ]
            {
                error only first element may be rooted ;
            }
        }
        return [ join-imp $(elements) ] ;
    }    
}


#
#    If 'path' is relative, it is rooted at 'root'. Otherwise, it's unchanged.
#
rule root ( path root )
{
    if [ is-rooted $(path) ] {
        return $(path) ;
    } else {
        return [ join $(root) $(path) ] ;
    }
}

#
#   Returns the current working directory.
#
rule pwd ( )
{
    return [ make [ PWD ] ] ;
}

#
#    Returns the list of files matching the given pattern in the specified directory.
#
rule glob ( dir : patterns + )
{
    return [ sequence.transform make : [ GLOB [ native $(dir) ] : $(patterns) ] ] ;
}

#
#    Returns true is the specified file exists.
#
rule exists ( file )
{
    return [ path.glob $(file:D) : $(file:D=) ] ;
}
NATIVE_RULE path : exists ;



#
#   Find out the absolute name of path and returns the list of all the parents,
#   starting with the immediate one. Parents are returned as relative names.
#   If 'upper_limit' is specified, directories above it will be pruned.
#
rule all-parents ( path : upper_limit ? : cwd ? )
{
    cwd ?= [ pwd ] ;
    local path_ele = [ regex.split [ root $(path) $(cwd) ] "/" ] ;

    if ! $(upper_limit) {
        upper_limit = / ;
    }
    local upper_ele = [ regex.split [ root $(upper_limit) $(cwd) ] "/" ] ;

    # Leave only elements in 'path_ele' below 'upper_ele'
    while $(path_ele) && $(upper_ele[1]) = $(path_ele[1]) {
        upper_ele = $(upper_ele[2-]) ;
        path_ele = $(path_ele[2-]) ;
    }
    
    # All upper elements removed ?
    if ! $(upper_ele) {
        # Create the relative paths to parents, number of elements in 'path_ele'
        local result ;
        for local i in $(path_ele) {
            path = [ parent $(path) ] ;
            result += $(path) ;
        }
        return $(result) ;
    }
    else {
        error "$(upper_limit) is not prefix of $(path)" ;
    }
}


#
#  Search for 'pattern' in parent directories of 'dir', up till and including
#  'upper_limit', if it is specified, or till the filesystem root otherwise.
#
rule glob-in-parents ( dir : patterns + : upper-limit ? )
{
    local result ;
    local parent-dirs = [ all-parents $(dir) : $(upper-limit) ] ;

    while $(parent-dirs) && ! $(result)
    {
        result = [ glob $(parent-dirs[1]) : $(patterns) ] ;
        parent-dirs = $(parent-dirs[2-]) ;
    }
    return $(result) ;    
}

#
# Assuming 'child' is a subdirectory of 'parent', return the relative
# path from 'parent' to 'child'
#
rule relative ( child parent )
{
    if $(parent) = "." 
    {
        return $(child) ;
    }
    else 
    {       
        local split1 = [ regex.split $(parent) / ] ;
        local split2 = [ regex.split $(child) / ] ;
    
        while $(split1)
        {
            if $(split1[1]) = $(split2[1])
            {
                split1 = $(split1[2-]) ;
                split2 = $(split2[2-]) ;
            }
            else
            {
                errors.error $(child) is not a subdir of $(parent) ;
            }                
        }    
        return [ join $(split2) ] ;    
    }    
}

# Returns the minimal path to path2 that is relative path1.
#
rule relative-to ( path1 path2 )
{
    local root_1 = [ regex.split [ reverse $(path1) ] / ] ;
    local split1 = [ regex.split $(path1) / ] ;
    local split2 = [ regex.split $(path2) / ] ;

    while $(split1) && $(root_1)
    {
        if $(split1[1]) = $(split2[1])
        {
            root_1 = $(root_1[2-]) ;
            split1 = $(split1[2-]) ;
            split2 = $(split2[2-]) ;
        }
        else
        {
            split1 = ;
        }
    }
    return [ join . $(root_1) $(split2) ] ;
}



rule make-NT ( native )
{
    local tokens = [ regex.split $(native) "[/\\]" ] ;
    local result ;

    # Handle paths ending with slashes
    if $(tokens[-1]) = ""
    {
        tokens = $(tokens[1--2]) ; # discard the empty element
    }

    result = [ path.join $(tokens) ] ;

    if [ regex.match "(^.:)" : $(native)  ]
    {
        result = /$(result) ;
    }
    
    if $(native) = ""
    {
        result = "." ;
    }
        
    return $(result) ;
}

rule native-NT ( path )
{
    local result = [ MATCH "^/?(.*)" : $(path) ] ;
    result = [ sequence.join [ regex.split $(result) "/" ] : "\\" ] ;
    return $(result) ;
}

rule make-UNIX ( native )
{
    # VP: I have no idea now 'native' can be empty here! But it can!
    if $(native) = ""
    {
        return "." ;
    }
    else
    {        
        return [ NORMALIZE_PATH $(native:T) ] ;
    }    
}

rule native-UNIX ( path )
{
    return $(path) ;
}

rule make-CYGWIN ( path )
{
    return [ make-NT $(path) ] ;
}

rule native-CYGWIN ( path )
{
    local result = $(path) ;
    if [ regex.match "(^/.:)" : $(path)  ] # win absolute
    {
        result = [ MATCH "^/?(.*)" : $(path) ] ; # remove leading '/'
    }
    return [ native-UNIX $(result) ] ;
}

rule __test__ ( ) {


    import assert ;
    import errors : try catch ;

    assert.true is-rooted "/" ;
    assert.true is-rooted "/foo" ;
    assert.true is-rooted "/foo/bar" ;
    assert.result : is-rooted "." ;
    assert.result : is-rooted "foo" ;
    assert.result : is-rooted "foo/bar" ;

    assert.true has-parent "foo" ;
    assert.true has-parent "foo/bar" ;
    assert.true has-parent "." ;
    assert.result : has-parent "/" ;

    assert.result "." : basename "." ;
    assert.result ".." : basename ".." ;
    assert.result "foo" : basename "foo" ;
    assert.result "foo" : basename "bar/foo" ;
    assert.result "foo" : basename "gaz/bar/foo" ;
    assert.result "foo" : basename "/gaz/bar/foo" ;

    assert.result "." : parent "foo" ;
    assert.result "/" : parent "/foo" ;
    assert.result "foo/bar" : parent "foo/bar/giz" ;
    assert.result ".." : parent "." ;
    assert.result ".." : parent "../foo" ;
    assert.result "../../foo" : parent "../../foo/bar" ;


    assert.result "." : reverse "." ;
    assert.result ".." : reverse "foo" ;
    assert.result "../../.." : reverse "foo/bar/giz" ;

    assert.result "foo" : join "foo" ;
    assert.result "/foo" : join "/" "foo" ;
    assert.result "foo/bar" : join "foo" "bar" ;
    assert.result "foo/bar" : join "foo/giz" "../bar" ;
    assert.result "foo/giz" : join "foo/bar/baz" "../../giz" ;
    assert.result ".." : join "." ".." ;
    assert.result ".." : join "foo" "../.." ;
    assert.result "../.." : join "../foo" "../.." ;
    assert.result "/foo" : join "/bar" "../foo" ;
    assert.result "foo/giz" : join "foo/giz" "." ;
    assert.result "." : join lib2 ".." ;
    assert.result "/" : join "/a" ".." ;

    assert.result /a/b : join /a/b/c .. ;

    assert.result "foo/bar/giz" : join "foo" "bar" "giz" ;
    assert.result "giz" : join "foo" ".." "giz" ;
    assert.result "foo/giz" : join "foo" "." "giz" ;

    try ;
    {
        join "a" "/b" ;
    }
    catch only first element may be rooted ;

    local CWD = "/home/ghost/build" ;
    assert.result : all-parents . : . : $(CWD) ;
    assert.result . .. ../.. ../../..  : all-parents "Jamfile" : "" : $(CWD) ;
    assert.result foo . .. ../.. ../../.. : all-parents "foo/Jamfile" : "" : $(CWD) ;
    assert.result ../Work .. ../.. ../../.. : all-parents "../Work/Jamfile" : "" : $(CWD) ;

    local CWD = "/home/ghost" ;
    assert.result . .. : all-parents "Jamfile" : "/home" : $(CWD) ;
    assert.result . : all-parents "Jamfile" : "/home/ghost" : $(CWD) ;
    
    assert.result "c/d" : relative "a/b/c/d" "a/b" ;
    assert.result "foo" : relative "foo" "." ;

    local save-os = [ modules.peek path : os ] ;
    modules.poke path : os : NT ;

    assert.result "foo/bar/giz" : make "foo/bar/giz" ;
    assert.result "foo/bar/giz" : make "foo\\bar\\giz" ;
    assert.result "foo" : make "foo/." ;
    assert.result "foo" : make "foo/bar/.." ;
    assert.result "/D:/My Documents" : make "D:\\My Documents" ;
    assert.result "/c:/boost/tools/build/new/project.jam" : make "c:\\boost\\tools\\build\\test\\..\\new\\project.jam" ;

    assert.result "foo\\bar\\giz" : native "foo/bar/giz" ;
    assert.result "foo" : native "foo" ;
    assert.result "D:\\My Documents\\Work" : native "/D:/My Documents/Work" ;

    modules.poke path : os : UNIX ;

    assert.result "foo/bar/giz" : make "foo/bar/giz" ;
    assert.result "/sub1" : make "/sub1/." ;
    assert.result "/sub1" : make "/sub1/sub2/.." ;    
    assert.result "sub1" : make "sub1/." ;
    assert.result "sub1" : make "sub1/sub2/.." ;
    assert.result "/foo/bar" : native "/foo/bar" ;

    modules.poke path : os : $(save-os) ;

}