gestion des url
Publié: 30 Jan 2005 à 12:54merci à son auteur
- Code : Tout sélectionner
' * Please read the Gnu General Public License before use:
' * http://www.gnu.org/licenses/gpl.txt
Public Class URL
' A wrapper for a URL in the form:
' protocol://username:password@host:port/file?query#reference
' Please note that the URL must be encoded and valid. The key/value
' delimiter is the encoded ampersand as stated in the XHTML standard.
' @author Johan Känngård, http://dev.kanngard.net/
' @version 0.9
url As String
protocol As String
host As String
port As Integer
path As String
file As String
query As String
username As String
password As String
reference As String
Public Sub new(url As String)
' Creates a new URL object from the specified URL String.
If Len(Trim(url)) = 0 Then Error 2000, "Invalid URL []"
Me.url = url
port = -1
query = Strright(url, "?")
If Instr(url, "#") Then query = Strleft(query, "#")
If Instr(url, "://") > 0 Then
protocol = Lcase(Strleft(url, "://"))
host = Strright(url, "://")
If Instr(host, "/") > 0 Then host = Strleft(host, "/")
If Instr(host, "@") > 0 Then
If Instr(Strleft(host, "@"), ":") > 0 Then
username = Strleft(host, ":")
password = Strleft(Strright(host, ":"), "@")
Else
username = Strleft(host, "@")
End If
host = Strright(host, "@")
End If
If Instr(host, ":") > 0 Then
If Isnumeric(Strright(host, ":")) Then port = Cint(Strright(host, ":"))
host = Strleft(host, ":")
End If
file = "/" + Strright(Strright(url, "://"), "/")
Else
file = url
End If
If Instr(file, "?") > 0 Then file = Strleft(file, "?")
If Instr(url, "#") > 0 Then
file = Strleft(file, "#")
reference = Strright(url, "#")
End If
path = file
If Len(query) > 0 Then file = file + "?" + query
If Len(reference) > 0 Then file = file + "#" + reference
End Sub
Public Function isAbsolute() As Variant
' Returns true if the URL has protocol and host.
isAbsolute = Len(protocol) > 0 And Len(host) > 0
End Function
Public Function getProtocol() As String
' Returns the protocol name, i.e "http", "https" etc.
getProtocol = protocol
End Function
Public Function getPort() As Integer
' Returns the port number part of the URL, or -1 if no port.
getPort = port
End Function
Public Function getHost() As String
' Returns the host part of the URL, or "" if no server.
getHost = host
End Function
Public Function getUserName() As String
' Returns the user name part, i.e. the URL
' "http://name:pwd@server.com/" returns "name"
getUserName = userName
End Function
Public Function getPassword() As String
' Returns the password part, i.e. the URL
' "http://name:pwd@server.com/" returns "pwd"
getPassword = password
End Function
Public Function getPath() As String
' Returns the path of this URL
getPath = path
End Function
Public Function getFile() As String
' Returns the filename of the URL.
getFile = file
End Function
Public Function getReference() As String
' Returns the anchor (aka "reference") of the URL
' The url "http://server.com/file.html#first" returns "first"
getReference = reference
End Function
Public Function getQuery() As String
' Returns the query part of the URL.
' I.e. the URL http://server.com/db.nsf/element?Open&Arg=value
' returns "Open&Arg=value"
getQuery = query
End Function
Public Function getArgumentValue(Byval key As String) As String
' Returns the FIRST value associated with a key (case insensitive)
' in the URL.
' I.e. the URL /home.nsf?Open&key=value and the key argument
' is "key" this method returns "value". If a key haven't got a value,
' this method returns the same value as the key. I.e. when the URL:
' /home.nsf?Open&Login and the key is "login", this method returns "Login".
getArgumentValue = ""
Dim i As Integer
Dim a As Variant
a = getArgumentValues()
For i = Lbound(a) To Ubound(a)
If Lcase(a(i, 0)) = Lcase(key) Then
getArgumentValue = a(i, 1)
Exit For
End If
Next i
End Function
Public Function getArgumentValues() As Variant
' Returns all key / values in the query as an array with two dimensions.
' The first dimension contains the key, the second the value.
Dim a As Variant
Dim s As String
s = getQuery()
If s = "" Then
Redim a(0 To 0, 0 To 1) As String
Else
Dim b As Variant
Dim delimiter As String
delimiter = "&"
b = explode(s, delimiter)
Redim a(Lbound(b) To Ubound(b), 0 To 1) As String
Dim c As Variant
Dim i As Integer
For i = Lbound(b) To Ubound(b)
c = explode(b(i), delimiter)
a(i, 0) = c(0)
If Ubound(c) - Lbound(c) > 1 Then
a(i, 1) = c(1)
Else
a(i, 1) = a(i, 0)
End If
Next i
End If
getArgumentValues = a
End Function
Private Function explode(fullString As String, separator As String) As Variant
' Explodes the specified fullString into an LS array at
' the specified separator.
' Source gotten from:
' http://www.breakingpar.com/bkp/home.nsf/Doc!OpenNavigator&U=87256B280015193F87256BE4004E28AB
Dim fullStringLen As Integer
Dim lastPosition As Integer
Dim position As Integer
Dim x As Integer
Dim tmpArray() As String
If separator = "" Then separator = " "
fullStringLen = Len(fullString)
lastPosition = 1
position = Instr(fullString, separator)
If position > 0 Then
Do While position > 0
x = x + 1
Redim Preserve tmpArray(x)
tmpArray(x-1) = Mid$(fullString, lastPosition, position - lastPosition)
lastPosition = position + Len(separator)
position = Instr(position+Len(separator), fullString, separator)
Loop
tmpArray(x) = Mid$(fullString, lastPosition)
Else
Redim tmpArray(0)
tmpArray(0) = fullString
End If
explode = tmpArray
End Function
Public Function toString() As String
' Returns the String representation of this URL.
toString = url
End Function
End Class