A VBScript equivalent of PHP’s FileSystem class
Class File_System
Private fso
Private ts
'
'Initialize Class
'
'@access private
'
Private Sub Class_Initialize()
Set fso = Server.CreateObject("Scripting.FileSystemObject")
End Sub
'
'Terminate Class
'
'@access private
'
Private Sub Class_Terminate()
Set fso = Nothing
End Sub
Function basename(path, suffix)
Dim b
b = preg_replace("/^.*[\/\\]/g",",path,null,null)
If len(suffix) > 0 Then
If Right(b,len(suffix)) = suffix Then
b = Left(b,len(b) - len(suffix))
End If
End If
basename = b
End Function
Public Function copy(source,dest)
fso.CopyFile source,dest
End Function
Public function fclose
ts.close
Set ts = Nothing
end function
Public function feof
feof = ts.AtEndofStream
end function
Public function fgetc
If ts.AtEndofStream Then
fgetc = false
Else
fgetc = ts.Read(1)
End If
end function
Public Function fgetcsv(delim)
Dim tmp,d
If len(delim) > 0 Then d = delim Else d = ","
tmp = ts.ReadLine
fgetcsv = fgetcsv_helper(tmp,d)
End Function
Public Function fgetcsv_helper(str,d)
Dim matchAll,key
Dim data,field,record : field = 0 : record = 0
ReDim data(0)
If preg_match_all(_
"/" & d & "|" & vbCr & "?" & vbLf & "|[^" & d & "" & vbCrLf & "][^" & d & " & vbCrLf & "]*|"(?:[^"]|"")*"/",_
str, matchAll,PREG_PATTERN_ORDER,") Then
For Each key In matchAll(0)
Select Case key
Case d
field = field + 1
Case vbCrLf
[] data , "
record = record +1
Case Else
If left(key,1) = "" Then
key = Replace(substr(key,2,-1),"","")
End if
[] data(record), key
End Select
Next
End If
fgetcsv_helper = data
End Function
Public function fgets
fgets = ts.ReadLine
end function
Public function fgetss
fgets = strip_tags(ts.ReadLine)
end function
Public Function file_exists(ByVal filename)
file_exists = false
filename = fileMapPath(filename)
If fso.FileExists(filename) Then file_exists = true
If fso.FolderExists(filename) Then file_exists = true
End Function
Public function file_get_contents(filename)
Dim ts
Dim contents
if left(filename,7) <> "http://" and file_exists( filename ) then
Set TS = fso.OpenTextFile( fileMapPath(filename),1)
'空のファイルの場合、エラーになってしまう
If TS.AtEndOfStream <> True Then
contents = TS.ReadAll
End If
file_get_contents = contents
Exit Function
end if
if left(filename,7) <> "http://" then
file_get_contents = false
Exit Function
end if
Dim objWinHttp
'Set objWinHttp = Server.CreateObject("WinHttp.WinHttpRequest.5.1")
'Set objWinHttp = Server.CreateObject("MSXML2.XMLHTTP")
Set objWinHttp = Server.CreateObject("MSXML2.ServerXMLHTTP")
objWinHttp.Open "GET", filename, false
objWinHttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
objWinHttp.Send
'Response.Write objWinHttp.Status & " " & objWinHttp.StatusText
file_get_contents = objWinHttp.ResponseText
Set objWinHttp = Nothing
'有効にしたエラー処理を無効にする
end function
Public Function fileatime(filename)
Dim f
filename = fileMapPath(filename)
set f = fso.GetFile(filename)
fileatime = f.DateLastAccessed
End Function
Public Function filemtime(filename)
Dim f
filename = fileMapPath(filename)
set f = fso.GetFile(filename)
filemtime = f.DateLastModified
End Function
Private Function fileMapPath(filename)
Dim tmp
tmp = Left(filename,3)
tmp = Lcase(tmp)
If tmp <> "d:\ and tmp <> "c:\" and left(filename,7) <> "http://" then
fileMapPath = Server.MapPath(filename)
Else
fileMapPath = filename
End If
End Function
Public Function filesize(filename)
Dim f
filename = fileMapPath(filename)
set f = fso.GetFile(filename)
filesize = f.Size
End Function
Public Function filetype(filename)
Dim f
filename = fileMapPath(filename)
set f = fso.GetFile(filename)
filetype = f.Type
End Function
Public function fopen(filename, mode)
Dim filePath
filePath = fileMapPath(filename)
If left(filePath,len("http://")) = "http://" Then
fopen = file_get_contents(filePath)
Exit Function
End If
Select Case mode
Case "r"
'読み込みのみでオープンします。
Set ts = fso.OpenTextFile(filePath,1,false)
Case "w"
'書き込みでオープンします。
Set ts = fso.OpenTextFile(filePath,2,true)
Case "a"
'追記でオープンします。
Set ts = fso.OpenTextFile(filePath,8,true)
Case "x"
'書き込みでオープンします。ファイルが存在した場合はfalseを返します。
If is_file(filePath) Then
fopen = false
Else
Set ts = fso.OpenTextFile(filePath,2,true)
End If
Case Else
'empty
ts = false
End Select
end function
Public function fputcsv(fields,delimiter,enclosure)
fputcsv = false
If len(delimiter) = 0 Then delimiter = ","
If len(enclosure) = 0 Then enclosure = ""
Dim key,replaced
For key = 0 to uBound(fields)
replaced = false
If inStr(fields(key),delimiter) or inStr(fields(key),enclosure) or inStr(fields(key),vbCrLf) Then
fields(key) = Replace(fields(key),enclosure,enclosure & enclosure)
fields(key) = enclosure & fields(key) & enclosure
End If
Next
Dim str : str = join(fields,delimiter)
ts.WriteLine str
fputcsv = len(str)
end function
Public function fputs(str)
fputs = fwrite(str)
end function
Public function fwrite(str)
ts.WriteLine str
end function
Public Function is_dir(filename)
Dim fn
is_dir = false
fn = fileMapPath(filename)
If fso.FolderExists(fn) Then is_dir = true
End Function
Public Function is_file(ByVal filename)
is_file = false
filename = fileMapPath(filename)
If fso.FileExists(filename) Then is_file = true
End Function
Public Function mkdir(ByVal pathname)
mkdir = false
pathname = fileMapPath(pathname)
If not fso.FolderExists(pathname) Then
mkdir = fso.CreateFolder(pathname)
End If
End Function
Public Function pathinfo(path,options)
Dim obj : set obj = Server.CreateObject("Scripting.Dictionary")
Dim tmp
obj("dirname") = dirname(path)
obj("basename") = basename(path,")
obj("extension") = obj("basename")
If inStr(obj("basename"),".") Then
tmp = Split(obj("basename"),".")
obj("extension") = tmp( uBound(tmp) )
End if
obj("filename") = Replace(obj("basename"),"." & obj("extension"),")
If len(options) > 0 Then
If options = PATHINFO_DIRNAME Then
pathinfo = obj("dirname")
ElseIf options = PATHINFO_BASENAME Then
pathinfo = obj("basename")
ElseIf options = PATHINFO_EXTENSION Then
pathinfo = obj("extension")
ElseIf options = PATHINFO_FILENAME Then
pathinfo = obj("filename")
End if
Exit Function
End If
set pathinfo = obj
End Function
Public Function rmdir(ByVal dirname)
dirname = fileMapPath(dirname)
fso.DeleteFolder dirname
rmdir = true
End Function
Public Function unlink(ByVal filename)
filename = fileMapPath(filename)
fso.DeleteFile filename
unlink = true
End Function
End Class
Please also note that php.vbs offers community built functions and goes by the McDonald’s Theory. We’ll put online functions that are far from perfect, in the hopes to spark better contributions. Do you have one? Then please just:
