WoodCoal.Base.Http.Client

本文最后更新时间：2009/03/08

'--------------------------------------------------
'
' 木炭通用扩展库 - 基础库
'
' namespace: WoodCoal.Base.HTTP.Utility
' author: 木炭(WoodCoal)
' homepage: http://www.woodcoal.cn/
' memo: 本版本以 WebClient 为基础扩展的功能
' release: 2009-03-08
'
'--------------------------------------------------
Namespace HTTP
Public Class Client
''' <summary>HTTP 请求对象</summary>
Private oHttp As Net.WebClient
''' <summary>Url 地址</summary>
Private xUrl As Uri = Nothing
''' <summary>保持文件路径</summary>
Private xFilePath As String = ""
''' <summary>文件名称</summary>
Private xFileName(1) As String
''' <summary>上传的内容</summary>
Private xPostString As String
''' <summary>页面语言</summary>
Private xCharset As String = ""
''' <summary>浏览器头</summary>
Private xUserAgent As String = "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1)"
''' <summary>Cookies 数据</summary>
Private xCookies As String = ""
Private Disposed As Boolean = False
Public Sub New()
Reset()
End Sub
Public Sub Dispose()
On Error Resume Next
If Not Disposed Then
oHttp.Dispose()
oHttp = Nothing
Disposed = True
End If
End Sub
Protected Overrides Sub Finalize()
Me.Dispose()
MyBase.Finalize()
End Sub
''' <summary>重设所有操作</summary>
Public Sub Reset()
If oHttp IsNot Nothing Then
oHttp.Dispose()
oHttp = Nothing
End If
oHttp = New Net.WebClient
oHttp.Headers.Add(Net.HttpRequestHeader.Accept, "*/*")
'oHttp.Headers.Add(Net.HttpRequestHeader.AcceptLanguage, "zh-cn")
'oHttp.Headers.Add(Net.HttpRequestHeader.AcceptEncoding, "gzip, deflate")
xUrl = Nothing
xCharset = ""
xUserAgent = "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1)"
xCookies = ""
xPostString = ""
xFilePath = ""
xFileName(0) = ""
xFileName(1) = ""
End Sub
'-------------------------------------------------------------------------------
''' <summary>需要操作的URL</summary>
Public Overloads Property Url() As String
Get
Return xUrl.AbsoluteUri
End Get
Set(ByVal Value As String)
Try
xUrl = New Uri(Value)
Catch ex As Exception
xUrl = Nothing
End Try
End Set
End Property
''' <summary>设置来源地址</summary>
Public WriteOnly Property Referer() As String
Set(ByVal Value As String)
oHttp.Headers.Add(Net.HttpRequestHeader.Referer, Value)
End Set
End Property
''' <summary>操作页面的语言编码</summary>
Public Property Charset() As String
Get
Return xCharset
End Get
Set(ByVal Value As String)
xCharset = Value
'If xCharset.Length < 3 Then xCharset = "UTF-8"
End Set
End Property
''' <summary>模拟浏览器名称</summary>
Public Property UserAgent() As String
Get
Return xUserAgent
End Get
Set(ByVal Value As String)
If Not String.IsNullOrEmpty(Value) Then xUserAgent = Value
End Set
End Property
''' <summary>文件保存路径</summary>
''' <param name="IsCreatedDir">路径不存在时，是否自动创建</param>
Public WriteOnly Property FilePath(Optional ByVal IsCreatedDir As Boolean = False) As String
Set(ByVal Value As String)
xFilePath = Files.Unti.TruePath(Value, IsCreatedDir)
End Set
End Property
''' <summary>文件保存路径</summary>
Public Property FileName() As String
Get
Return xFileName(1)
End Get
Set(ByVal value As String)
xFileName(0) = value
End Set
End Property
''' <summary>设置获取Cookies</summary>
Public Property Cookies() As String
Get
On Error Resume Next
Dim Value As String = oHttp.ResponseHeaders(Net.HttpResponseHeader.SetCookie)
If String.IsNullOrEmpty(Value) Then Value = xCookies
Return Value
End Get
Set(ByVal value As String)
xCookies = value.Replace(vbCrLf, ";")
oHttp.Headers.Add(Net.HttpRequestHeader.Cookie, xCookies)
End Set
End Property
''' <summary>设置获取页面请求头</summary>
Public Overloads ReadOnly Property Header() As Net.WebHeaderCollection
Get
Return oHttp.ResponseHeaders
End Get
End Property
''' <summary>设置获取页面请求头</summary>
''' <param name="key">头名称</param>
Public Overloads Property Header(ByVal key As String) As String
Get
Return oHttp.ResponseHeaders(key)
End Get
Set(ByVal value As String)
oHttp.Headers.Add(key, value)
End Set
End Property
''' <summary>获取附件名称</summary>
Public ReadOnly Property Attachment() As String
Get
Dim Value As String = oHttp.ResponseHeaders("Content-Disposition")
If Not String.IsNullOrEmpty(Value) AndAlso Value.ToLower.Contains("filename=") Then
Value = Split(Value, "filename=")(1)
Value = Value.Replace("""", "").Replace("'", "")
End If
Return Value
End Get
End Property
''' <summary>获取附件名称</summary>
Public ReadOnly Property MIME() As String
Get
Return oHttp.ResponseHeaders(Net.HttpResponseHeader.ContentType)
End Get
End Property
''' <summary>设置需要上传的表单内容</summary>
Public Overloads Property PostString() As String
Get
Return xPostString
End Get
Set(ByVal value As String)
xPostString = value
End Set
End Property
''' <summary>设置需要上传的表单内容</summary>
Public Overloads WriteOnly Property PostString(ByVal Key As String) As String
Set(ByVal value As String)
If Not String.IsNullOrEmpty(Key) And Not String.IsNullOrEmpty(value) Then
If xCharset.Length < 3 Then
value = Web.HttpUtility.UrlEncode(value, Text.Encoding.GetEncoding("UTF-8"))
Else
value = Web.HttpUtility.UrlEncode(value, Text.Encoding.GetEncoding(xCharset))
End If
xPostString &= "&" & Key & "=" & value
End If
If xPostString.StartsWith("&") Then xPostString = xPostString.Substring(1)
End Set
End Property
'-------------------------------------------------------------------------------
''' <summary>获取网页源码</summary>
Public Overloads Function Html() As String
Html = ""
If xUrl IsNot Nothing Then
Try
oHttp.Headers.Add(Net.HttpRequestHeader.UserAgent, xUserAgent)
'默认使用 UTF-8 编码
Dim retByte As Byte()
If xPostString.Length > 0 Then
oHttp.Headers.Add(Net.HttpRequestHeader.ContentType, "application/x-www-form-urlencoded")
retByte = oHttp.UploadData(xUrl, "POST", Text.Encoding.Default.GetBytes(xPostString))
Else
retByte = oHttp.DownloadData(xUrl)
End If
Dim contentType As String = oHttp.ResponseHeaders("Content-Type").ToLower
' 必须返回文本格式的内容才获取实际内容
If contentType.Contains("text") Or contentType.Contains("html") Or contentType.Contains("xml") Then
If xCharset.Length < 1 Then
'1. BOM(Byte Order Mark) 提取编码
If retByte(0) > &HEE Then
If retByte(0) = &HEF And retByte(1) = &HBB And retByte(2) = &HBF Then xCharset = "UTF-8"
If retByte(0) = &HFE And retByte(1) = &HFF Then xCharset = "Big-Endian"
If retByte(0) = &HFF And retByte(1) = &HFE Then xCharset = "Unicode"
End If
If xCharset.Length < 1 Then
'2. Header 提取编码
' Content-Type: text/html; charset=UTF-8
' 正则表达式：charset\b\s*=\s*(?<charset>[^""]*)
If contentType.Contains("charset=") AndAlso Text.RegularExpressions.Regex.IsMatch(contentType, "charset\b\s*=\s*(?<charset>[^""]*)") Then xCharset = Text.RegularExpressions.Regex.Match(contentType, "charset\b\s*=\s*(?<charset>[^""]*)").Groups("charset").Value
End If
If xCharset.Length < 1 Then
'3. HTML 代码中提取
' <meta http-equiv=content-type content="text/html; charset=GB2312">
' 正则表达式：(<meta[^>]*charset=(?<charset>[^>'""]*)[\s\S]*?>)|(xml[^>]+encoding=(""|')*(?<charset>[^>'""]*)[\s\S]*?>)
Dim Match As Text.RegularExpressions.Match = Text.RegularExpressions.Regex.Match(Text.Encoding.Default.GetString(retByte), "(<meta[^>]*charset=(?<charset>[^>'""]*)[\s\S]*?>)|(xml[^>]+encoding=(""|')*(?<charset>[^>'""]*)[\s\S]*?>)", Text.RegularExpressions.RegexOptions.IgnoreCase)
If Match.Length > 0 Then xCharset = IIf((Match.Captures.Count <> 0), Match.Result("${charset}"), "")
End If
End If
If xCharset.Length > 1 Then
Html = Text.Encoding.GetEncoding(xCharset).GetString(retByte)
Else
Html = Text.Encoding.Default.GetString(retByte)
End If
End If
Catch e As Exception
End Try
End If
End Function
''' <summary>获取网页源码</summary>
''' <param name="UrlAddress">要获取的网址</param>
Public Overloads Function Html(ByVal UrlAddress As String) As String
Url = UrlAddress
Return Me.Html
End Function
''' <summary>获取网页源码</summary>
''' <param name="UrlAddress">要获取的网址</param>
''' <param name="PageCharset">访问页面的语言编码</param>
Public Overloads Function Html(ByVal UrlAddress As String, ByVal PageCharset As String) As String
Charset = PageCharset
Url = UrlAddress
Return Me.Html
End Function
'-------------------------------------------------------------------------------
''' <summary>获取网页源码</summary>
Public Overloads Function Stream() As IO.Stream
If xUrl IsNot Nothing Then
Try
oHttp.Headers.Add(Net.HttpRequestHeader.UserAgent, xUserAgent)
Return oHttp.OpenRead(xUrl)
Catch e As Exception
End Try
End If
Return Nothing
End Function
''' <summary>获取网页源码</summary>
Public Overloads Function Stream(ByVal UrlAddress As String) As IO.Stream
Url = UrlAddress
Return Me.Stream()
End Function
'-------------------------------------------------------------------------------
''' <summary>下载文件</summary>
''' <param name="Overwrite">是否自动创建</param>
Public Overloads Function Download(Optional ByVal Overwrite As Boolean = True) As Boolean
Dim Value As Boolean = False
If xUrl IsNot Nothing Then
xFileName(1) = xFileName(0)
If xFileName(1).Length < 1 Then xFileName(1) = xUrl.GetHashCode
If xFilePath.Length < 3 Then xFilePath = Files.Unti.Root
If Not xFilePath.EndsWith("\") Then xFilePath &= "\"
'检查 OverWrite
If Not Overwrite Then
'检查是否存在文件，存在则不需要下载直接返回 True
If IO.File.Exists(xFilePath & xFileName(1)) Then Value = True
End If
If Not Value Then
Try
oHttp.Headers.Add(Net.HttpRequestHeader.UserAgent, xUserAgent)
oHttp.DownloadFile(xUrl, xFilePath & xFileName(1))
Dim fileExt As String = IO.Path.GetExtension(xFileName(1))
'没有扩展名，从下载的数据中获取名称
If String.IsNullOrEmpty(fileExt) Then
If Not String.IsNullOrEmpty(Attachment) Then fileExt = IO.Path.GetExtension(Attachment)
'没有扩展名，从服务器返回文件类型获取
If String.IsNullOrEmpty(fileExt) Then
fileExt = Unti.Mime2Ext(MIME)
If Not String.IsNullOrEmpty(fileExt) Then
'换回文件类型组，如：jpg,jpeg...
fileExt = fileExt.Split(","c)(0)
End If
End If
'没有扩展名，从路径获取
If String.IsNullOrEmpty(fileExt) Then fileExt = IO.Path.GetExtension(xUrl.AbsoluteUri)
If Not String.IsNullOrEmpty(fileExt) Then
'过滤“？、#”
fileExt = fileExt.Replace("?", " ").Replace("#", " ")
fileExt = Split(fileExt, " ")(0)
End If
If Not String.IsNullOrEmpty(fileExt) Then
Dim trueFile As String = xFileName(1) & "." & fileExt
If IO.File.Exists(xFilePath & trueFile) And Not Overwrite Then
Value = True
Exit Try
Else
'删除旧文件
IO.File.Delete(xFilePath & trueFile)
End If
'重命名文件
If IO.File.Exists(xFilePath & xFileName(1)) Then
IO.File.Copy(xFilePath & xFileName(1), xFilePath & trueFile)
IO.File.Delete(xFilePath & xFileName(1))
End If
xFileName(1) = trueFile
End If
End If
Value = True
Catch e As Exception
Value = False
End Try
End If
End If
If Not Value Then xFileName(1) = ""
Return Value
End Function
''' <summary>下载文件</summary>
''' <param name="UrlAddress">要操作的网页地址</param>
''' <param name="Overwrite">是否自动创建</param>
Public Overloads Function Download(ByVal UrlAddress As String, Optional ByVal Overwrite As Boolean = True) As Boolean
Url = UrlAddress
Return Me.Download(Overwrite)
End Function
''' <summary>下载文件</summary>
''' <param name="UrlAddress">要操作的网页地址</param>
''' <param name="SaveFilePath">下载后文件保存路径</param>
''' <param name="Overwrite">是否自动创建</param>
Public Overloads Function Download(ByVal UrlAddress As String, ByVal SaveFilePath As String, ByVal SaveFileName As String, Optional ByVal Overwrite As Boolean = True) As Boolean
Url = UrlAddress
FilePath = SaveFilePath
FileName = SaveFileName
Download = Me.Download(Overwrite)
End Function
End Class
End Namespace